自动获得远程图片 #Writ

　　程序实现功能：自动将远程页面的文件中的图片下载到本地服务器

　　将下文保存为 save2local.asp
测试：save2local.asp?url=

　　<%
参数设置开始
url = request(url)
localaddr = server.MapPath(images_remote/) 保存到本地的目录
localdir = images_remote/ http 访问的相对路径
AllowFileExt = jpgbmppnggif 支持的文件名格式
参数设置完毕

　　if createdir(localaddr) = false then
response.Write 创建目录失败，请检查目录权限
response.End
end if
response.Write Convert2LocalAddr(url,localaddr,localdir)

　　function Convert2LocalAddr(url,localaddr,localdir)
参数说明
url 页面地址
localaddr 保存本地的物理地址
localdir 相对路径
strContent = getHTTPPage(url)
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = <img.+?>
Set Matches =objRegExp.Execute(strContent)
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=baseurlcstr(imid(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 = GenerateRandomFileName(fname)
call Save2Local(ImagesFileName,localaddr / newfilename)
RemoteImage=RemoteImage ImagesFileName
LocalImage=LocalImage localdir newfilename
end if
end if
next
arrnew=split(LocalImage,)
arrall=split(RemoteImage,)
for i=1 to ubound(arrnew)
strContent=replace(strContent,arrall(i),arrnew(i))
next
Convert2LocalAddr = strContent
end function

　　function GetRemoteImages(str)
Set objRegExp1 = New Regexp
objRegExp1.IgnoreCase = True
objRegExp1.Global = True
objRegExp1.Pattern =
set mm=objRegExp1.Execute(str)
For Each Match1 in mm
tmpaddr = left(Match1.Value,len(Match1.Value)-1)
GetRemoteImages=GetRemoteImages replace(replace(tmpaddr,,),,)
next
end function

　　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

　　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

　　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

　　function 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 function

　　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=geturlencodelmid(Url,i,1)
end if
next
end function

　　Function GenerateRandomFileName(ByVal szFilename) 根据原文件名，自动以日期YYYY-MM-DD-RANDOM格式生成新文件名
Randomize
ranNum = Int(90000 * Rnd) + 10000
If Month(Now) < 10 Then c_month = 0 Month(Now) Else c_month = Month(Now)
If Day(Now) < 10 Then c_day = 0 Day(Now) Else c_day = Day(Now)
If Hour(Now) < 10 Then c_hour = 0 Hour(Now) Else c_hour = Hour(Now)
If Minute(Now) < 10 Then c_minute = 0 Minute(Now) Else c_minute = Minute(Now)
If Second(Now) < 10 Then c_second = 0 Second(Now) Else c_second = Minute(Now)
fileExt_a = Split(szFilename, .)
FileExt = LCase(fileExt_a(UBound(fileExt_a)))
GenerateRandomFileName = Year(Now) c_month c_day c_hour c_minute c_second _ ranNum . FileExt
End Function

　　Function CreateDIR(ByVal LocalPath) 建立目录的程序，如果有多级目录，则一级一级的创建
On Error Resume Next
LocalPath = Replace(LocalPath, , /)
Set FileObject = server.CreateObject(Scripting.FileSystemObject)
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

　　function GetfileExt(byval filename)
fileExt_a=split(filename,.)
GetfileExt=lcase(fileExt_a(ubound(fileExt_a)))
end function
%>