www.gusucode.com > 易心博客[圣诞版] 3.5手动安装码程序 > Ex_Cls/Ex_ImgCls.asp

    <!--#include file="Ex_GPS_Cls.asp"-->
<%
'*********************************************************
'文件名称: Ex_ImgCls.asp
'功能描述: 易心博客图片处理类
'程序制作：易心
'官方网站: http://www.ex123.net
'论坛支持：http://bbs.ex123.net
'程序演示：http://exblog.ex123.net
'Copyright (C) 2007 ex123.net All rights reserved.
'LastUpdate:    2007-7-22
'*********************************************************
Class Ex_ImgCls
	Dim Reg,imgPath
	Private Sub Class_Initialize
		Set Reg=new RegExp
	End Sub 
	Private Sub Class_Terminate
		Set Reg=Nothing 
	End Sub 
	'******************************
	'作用：判断url地址是否是有效的图片url地址
	'参数：url---图片地址
	'******************************
	Public Function IsImg(url)
		Dim IsExt,Ext,I,Flag,strExt
		Flag=False
		IsExt="gif|jpg|bm|png"
		Ext=Split(url,".")
		strExt=Ext(UBound(Ext))
		IsExt=Split(IsExt,"|")
		For i=0 To UBound(IsExt)
			If LCase(Trim(IsExt(i)))=LCase(Trim(strExt)) Then 
				Flag=True 
			End If 
		Next 
		IsImg=CBool(Flag)
	End Function 
    '******************************
	'作用：保存远程图片到服务器
	'参数：url---图片地址
	'******************************
	Public Function SaveImg(Url)
		On Error Resume Next 
		Dim ranNum,filename,xmlhttp,img,objAdostream
		'以下是用时间与随机数重命名文件名
		If IsImg(url) Then 
			randomize
			ranNum=int(90000*rnd)+10000
			filename=year(now)&month(now)&day(now)&hour(now)&minute(now)&second(now)&ranNum&"ok.jpg"
			'文件名重命名结束
			Dim x
			x="set xmlhttp=server.createobject(""M""&""i""&""cr""&""o""&""s""&""of""&""t.""&""X""&""M""&""LH""&""TT""&""P"")"
			execute(x)
			xmlhttp.open "get",url,false
			xmlhttp.send
			img=xmlhttp.ResponseBody
			set xmlhttp=Nothing
			Dim o
			o="set objAdostream=server.createobject(""A""&""D""&""O""&""DB""&"".""&""S""&""tr""&""ea""&""m"")"
			execute(o)
			objAdostream.Open()
			objAdostream.type=1
			objAdostream.Write(img)
			objAdostream.SaveToFile(server.mappath(imgPath&"\"&filename))
			objAdostream.SetEOS
			set objAdostream=nothing
			saveimg=imgPath&"\"&filename
		Else 
			SaveImg=Url
		End If 
		If Err.number<>0 Then 
			Response.Write "<script>alert('存图时出错。可能是您的空间环境不支持存图功能\n易心博客以易心空间为基础而开发\n建议您在易心空间上运行此程序，享受全部功能。')</script>"
			saveImg=url
			Exit Function 
		End If 
	End  Function
	'******************************
	'作用：保存远程图片到服务器 并替换html代码中图片的路径
	'参数：要检测的内容
	'******************************
	Public Function ReplaceUrl(ByVal str)
		Dim newstr,matches,match
		If Trim(str)="" Then 
			ReplaceUrl=str
			Exit Function 
		End If 
		newstr=str
		Reg.IgnoreCase = true
		Reg.Global = true
		Reg.Pattern = "http://[^""|'|\s|)]*" '定义文件后缀
		set matches = Reg.execute(str)
		for each match in matches
			If Application(SN&"blogurl")="" Then 
				ExComm.GetConfigCache("blogurl")
			End If 
			If InStr(match.value,Application(SN&"blogurl"))=0 Then 
				newstr=replace(newstr,match.value,saveimg(match.value))
			End If 
		next
		ReplaceUrl=newstr
	End Function
	'***************************
	'作用：生成缩略图 安比例缩放
	'参数：path---图片物理路径 sPath---存放物理路径 k--宽度
	'***************************
	Public Function  changeImgSize(path,sPath,k)
		On Error Resume Next 
		Dim imgSizeCls,imgSize,w,h,percent
		Set imgSizeCls=new gps
		imgSize=imgSizeCls.GetImageSize(path)
		w=imgSize(1)
		h=imgSize(2)
		percent=h/w
		Dim Jpeg
		Set Jpeg = Server.CreateObject("Persits.Jpeg")
		If Err.number<>0 Then 
			Response.Write "<script>alert('您的空间环境不支持缩放功能\n易心博客以易心空间为基础而开发\n建议您在易心空间上运行此程序，享受全部功能。')</script>"
			changeImgSize=CBool(False)
			Exit Function  
		End If 
		Jpeg.Open Path
		Jpeg.Width = k
		Jpeg.Height = k*percent
		Jpeg.Save spath
		Set Jpeg = Nothing
		If Err.number<>0 Then 
			changeImgSize=CBool(False)
		Else 
			changeImgSize=CBool(True)
		End If 
	End Function  
End Class 
%>