<% ' Set time to timeout server.scripttimeout=9999 '############## ' File Save function '############# function SaveToFile (from,tofile) On Error Resume Next Dim Geturl,objstream,imgs Geturl=trim (from) Mybyval=gethttpstr (Geturl) Set objstream = Server.CreateObject ("ADODB. Stream ") objStream.Type =1 objStream.Open Objstream.write Mybyval Objstream. SaveToFile tofile,2 Objstream. Close () Set objstream=nothing If Err.number<>0 then err. Clear End Function
'############## ' Character processing substitution '############# Function Geturlencodel (ByVal URL) ' Chinese filename conversion 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 '############## ' XML get remote page start '############# 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 '############## ' XML gets the remote page end, which is a common part of the Thief program '#############
'############## ' Decompose address, get filename '############# Function GetFileName (ByVal filename) If InStr (filename, "/") >0 Then Fileext_a=split (filename, "/") Getfilename=lcase (Fileext_a (UBound (fileext_a)) If InStr (GetFileName, "?") >0 Then Getfilename=left (Getfilename,instr (GetFileName, "?") -1) End If Else Getfilename=filename End If End Function
'############## ' Get the remote page function '############# function gethttpstr (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 Gethttpstr=http.responsebody Set http=nothing If Err.number<>0 then err. Clear End Function
'############## ' FSO processing function, creating a directory '############# Function Createdir (ByVal localpath) ' Directory-building program, if there is a multilevel directory, then one-level creation 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
'############## ' How to get the virtual path '############# function Getvirtual (str,path,urlhead) If left (str,7) = "http://" then Url=str ElseIf Left (str,1) = "/" Then Start=instrrev (str, "/") If Start=1 Then Url= "/" Else Url=left (Str,start) End If Url=urlhead&url ElseIf Left (str,3) = ". /"Then Str1=mid (str, str,instrrev). /") +2) Ar=split (str, ". /") Lv=ubound (AR) +1 Ar=split (Path, "/") Url= "/" For I=1 to (UBound (AR)-lv) Url=url&ar (i) Next Url=url&str1 Url=urlhead&url Else Url=urlhead&str End If Getvirtual=url End Function |