<%
Class cls_RemoteImages
	Public Function ReplaceRemoteUrl(strContent)
		dim localaddr,localdir,AllowFileExt,cf
		localaddr = Server.Mappath("../images_remote/"&FormatMyDate(Now(),"{Y}-{m}")&"/")  '保存到本地的目录
		cf = CreatePath(localaddr)
		Response.Write localaddr
		localdir = "/images_remote/"&FormatMyDate(Now(),"{Y}-{m}")&"/"  'http 访问的相对路径
		AllowFileExt = "jpg|bmp|png|gif" '支持的文件名格式
		'strContent = getHTTPPage(url)
		dim objRegExp,Matches,RetStr,ImagesArray,RemoteImage,LocalImage,i,fname,ImagesFileName,isGetFile,newFileName,AllowFileExtArray,tmp
		Set objRegExp = New Regexp
		objRegExp.IgnoreCase = True
		objRegExp.Global = True
		objRegExp.Pattern = "<img.+?>|<IMG.+?>"
		Set Matches =objRegExp.Execute(strContent)
		dim Match
		For Each Match in Matches
			RetStr = RetStr & GetRemoteImages(Match.Value)
		Next
		ImagesArray=split(RetStr,"||")
		RemoteImage=""
		LocalImage=""
		for i=1 to ubound(ImagesArray)
			if ImagesArray(i)<>"" and instr(RemoteImage,ImagesArray(i))<1 then
				fname=cstr(i&mid(ImagesArray(i),instrrev(ImagesArray(i),".")))
				ImagesFileName = ImagesArray(i)
				AllowFileExtArray = split(AllowFileExt,"|")
				isGetFile = false
				for tmp = 0 to ubound(AllowFileExtArray)
					if lcase(GetFileExt(ImagesFileName)) = ALlowFileExtArray(tmp) then
						isGetFile=True
					end if
				next
				if isGetFile = true then
					newfilename =  GetRndFileName(Fname)
					call Save2Local(ImagesFileName,localaddr & "/" & newfilename)
					RemoteImage=RemoteImage&"||"& ImagesFileName
					LocalImage=LocalImage&"||" & localdir & newfilename
				end if
			end if
		next
		'Response.Write(RemoteImage)
		Dim arrnew,arrall
		arrnew=split(LocalImage,"||")
		arrall=split(RemoteImage,"||")
		for i=1 to ubound(arrnew)
			strContent=replace(strContent,arrall(i),arrnew(i), 1, -1, 1)
		next
		ReplaceRemoteUrl = strContent
	end function
	'---------------------------------------------------------------------
	'时间格式化
	'参数：时间，格式模板
	'返回：格式化后的字符串
	'备注：格式化关键词详解：
	'	"{Y}" : 4位年
	'	"{y}" : 2位年
	'	"{M}" : 不补位的月
	'	"{m}" : 补位的月,如03,01
	'	"{D}" : 不补位的日
	'	"{d}" : 补位的日
	'	"{H}" : 不补位的小时
	'	"{h}" : 补位的小时
	'	"{MI}": 不补位的分钟
	'	"{mi}": 补位的分钟
	'	"{S}" : 不补位的秒
	'	"{s}" : 补位的秒
	'---------------------------------------------------------------------
	Public Function FormatMyDate(myDate,Template)
		If Not IsDate(myDate) Or Template = "" Then
			FormatMyDate = Template
			Exit Function
		End If

		Dim mYear,mMonth,mDay,mHour,mMin,mSec
			mYear = Year(myDate)
			mMonth = Month(myDate)
			mDay = Day(myDate)
			mHour = Hour(myDate)
			mMin = Minute(myDate)
			mSec = Second(myDate)

		Template = Replace(Template,"{Y}",Year(myDate))
		Template = Replace(Template,"{y}",Right(Year(myDate),2))
		Template = Replace(Template,"{M}",Month(myDate))
		Template = Replace(Template,"{m}",Right("00" & Month(myDate),2))
		Template = Replace(Template,"{D}",Day(myDate))
		Template = Replace(Template,"{d}",Right("00" & Day(myDate),2))
		Template = Replace(Template,"{H}",Hour(myDate))
		Template = Replace(Template,"{h}",Right("00" & Hour(myDate),2))
		Template = Replace(Template,"{MI}",Minute(myDate))
		Template = Replace(Template,"{mi}",Right("00" & Minute(myDate),2))
		Template = Replace(Template,"{S}",Second(myDate))
		Template = Replace(Template,"{s}",Right("00" & Second(myDate),2))
		FormatMyDate = Template
		Template = Null
	End Function
	Private function GetRemoteImages(str)
		dim objRegExp,mm,Match,tmpaddr
		Set objRegExp = New Regexp
		objRegExp.IgnoreCase = True
		objRegExp.Global = True
		objRegExp.Pattern = "http://.+? "
		set mm=objRegExp.Execute(str)
		For Each Match in mm
			tmpaddr = left(Match.Value,len(Match.Value)-1)
			GetRemoteImages=GetRemoteImages&"||" & replace(replace(tmpaddr,"""",""),"'","")
		next
	End function

	Private function getHTTPPage(url) 
		on error resume next 
		dim http 
		set http=Server.createobject("Msxml2.XMLHTTP") 
		Http.open "GET",url,false 
		Http.send() 
		if Http.readystate<>4 then	exit function 
		getHTTPPage=bytes2BSTR(Http.responseBody) 
		set http=nothing
		if err.number<>0 then err.Clear  
	end function 

	Private Function bytes2BSTR(vIn) 
		dim strReturn 
		dim i,ThisCharCode,NextCharCode 
		strReturn = "" 
		For i = 1 To LenB(vIn) 
			ThisCharCode = AscB(MidB(vIn,i,1)) 
			If ThisCharCode < &H80 Then 
				strReturn = strReturn & Chr(ThisCharCode) 
			Else 
				NextCharCode = AscB(MidB(vIn,i+1,1)) 
				strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode)) 
				i = i + 1 
			End If 
		Next 
		bytes2BSTR = strReturn 
	End Function 

	Private function getHTTPimg(url)
		on error resume next
		dim http
		set http=server.createobject("MSXML2.XMLHTTP")
		Http.open "GET",url,false
		Http.send()
		if Http.readystate<>4 then 	exit function
		getHTTPimg=Http.responseBody
		set http=nothing
		if err.number<>0 then err.Clear 
	end function

	Private Sub Save2Local(from,tofile)
		dim geturl,objStream,imgs
		geturl=trim(from)
		imgs=gethttpimg(geturl)
		Set objStream = Server.CreateObject("ADODB.Stream")
		objStream.Type =1
		objStream.Open
		objstream.write imgs
		objstream.SaveToFile tofile,2
		objstream.Close()
		set objstream=nothing
	End Sub

	Private function geturlencodel(byval url)'中文文件名转换
		Dim i,code
		geturlencodel=""
		if trim(Url)="" then exit function
		for i=1 to len(Url)
			code=Asc(mid(Url,i,1))
			if code<0 Then code = code + 65536
			If code>255 Then
				geturlencodel=geturlencodel&"%"&Left(Hex(Code),2)&"%"&Right(Hex(Code),2)
			else
				geturlencodel=geturlencodel&mid(Url,i,1)
			end if
		next
	end function 

	' 取随机文件名
	Public Function GetRndFileName(sFileName)
		Dim sRnd
		Randomize
		sRnd = Int(900 * Rnd) + 100		
		GetRndFileName = FormatMyDate(Now(),"{Y}{m}{d}_{h}{mi}{s}_") & sRnd & "." & GetFileExt(sFileName)
		GetRndFileName = GetRndFileName
	End Function
	Private function GetFileExt(byval sFileName)
		dim fileExt_a
		fileExt_a=split(sFileName,".")
		GetfileExt=lcase(fileExt_a(ubound(fileExt_a)))
	end function
	Function CreateDIR(ByVal LocalPath) '建立目录的程序，如果有多级目录，则一级一级的创建
		On Error Resume Next
		dim FileObject,patharr,path_level,i,pathtmp,cpath
		LocalPath = Replace(LocalPath, "\", "/")
		Set FileObject = server.CreateObject(Mesky.Setting(23))
		patharr = Split(LocalPath, "/")
		path_level = UBound(patharr)
		For I = 0 To path_level
			If I = 0 Then pathtmp = patharr(0) & "/" Else pathtmp = pathtmp & patharr(I) & "/"
			cpath = Left(pathtmp, Len(pathtmp) - 1)
			If Not FileObject.FolderExists(cpath) Then FileObject.CreateFolder cpath
		Next
		Set FileObject = Nothing
		If Err.Number <> 0 Then
			CreateDIR = False
			Err.Clear
		Else
			CreateDIR = True
		End If
	End Function

	'================================================
	'作  用：检查组件是否已经安装
	'参  数：strClassString ----组件名
	'返回值：True  ----已经安装
	'        False ----没有安装
	'================================================
	Private Function IsObjInstalled(strClassString)
		On Error Resume Next
		IsObjInstalled = False
		Err = 0
		Dim xTestObj
		Set xTestObj = Server.CreateObject(strClassString)
		If 0 = Err Then IsObjInstalled = True
		Set xTestObj = Nothing
		Err = 0
	End Function
	
	'########################
	Private Function CreatePath(sPath) '创建文件夹函数, sPath为文件夹绝对路径,可以是多层文件夹
	'########################
		Dim f,pos,aTmp,sNewPath,n
		If Instr(sPath,"\")>0 Then
			Set f=Server.CreateObject(Mesky.Setting(23))
			pos=Instr(3,sPath,"\",1)
			aTmp=Split(Mid(sPath,pos+1),"\")
			sNewPath=Left(sPath,pos-1)
			For n = 0 to Ubound(aTmp)
				On Error resume next 'Ignore permission problems on higher levels
				sNewPath = sNewPath & "\" & aTmp(n)
				If aTmp(n)<>"" AND NOT f.FolderExists(sNewPath) Then f.CreateFolder sNewPath
			Next
			If f.FolderExists(sPath) Then CreatePath=True Else CreatePath=False
			Set f=Nothing
		End If
	End Function
End Class
%>