Tutorials to .com

Tutorials to .com » Asp » Xml » XMLHTTP friends dedicated to learning

XMLHTTP friends dedicated to learning

Print View , by: iSee ,Total views: 4 ,Word Count: 1458 ,Date: Wed, 22 Apr 2009 Time: 6:49 AM


Long time not written anything today chinahuman read the "use automatic analytical asp page image addresses, and save it to a local server", so to optimize the process and all the functions of a function, in the hope that Learning XMLHTTP help of a friend.
Program features: automatic remote document page images downloaded to the local.

<%
'Will be saved as save2local.asp this article
'Test: save2local.asp? Url = http://ent.sina.com.cn/s/m/2003-11-11/1411231388.html
'In this paper, according chinahuman the "use automatic analytical asp page image addresses, and save it to a local server," adapted and optimized
'Automatically creates a directory, automatically rename the original file name, file format restrictions, as well as a number of other functions to optimize
'Auto-Save file format http:// .... the picture to the local
'Reprint please specify the source: http://www.jaron.cn http://www.csdn.net/develop
'Parameter set to start
url = request ( "url")
localaddr = server.MapPath ( "images_remote /") 'save to a local directory
localdir = "images_remote /" 'http access to the relative path
AllowFileExt = "jpg | bmp | png | gif" 'supported by the file name format
'Parameter is set up

if createdir (localaddr) = false then
response.Write "failed to create the directory, check directory permissions"
response.End
end if
response.Write Convert2LocalAddr (url, localaddr, localdir)

function Convert2LocalAddr (url, localaddr, localdir)
'Parameter Explanation
'url page address
'localaddr preservation of the physical address of the local
'localdir relative path
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 = baseurl & 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 = 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 = "http://. +?"
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) 'Chinese file name 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

Function GenerateRandomFileName (ByVal szFilename) 'in accordance with the original file name, automatically date YYYY-MM-DD-RANDOM format to generate a new file name
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) 'create the directory of the procedure, if a number of class directory, create a level
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
%>




It should be noted that the analysis here only to the http address at the beginning of the picture. Otherwise, do not download pictures, you can change the address on the list, and then a few small functions, analysis of the address used:

Function findurl (thisurl)
if thisurl <> "" Then
findurl = ""
strlen = InStr (8, thisurl ,"/")
If strlen = 0 Then strlen = 1
findurl = Mid (thisurl, strlen, 28)
end if
end Function

function findurlpath (thisurl)
thisurl = replace (thisurl ,"//","@@")
ary_tmp = split (thisurl ,"/")
for tmp = 0 to ubound (ary_tmp)
if tmp <ubound (ary_tmp) then
urltmp = urltmp & "/" & ary_tmp (tmp)
end if
next
urltmp = right (urltmp, len (urltmp) -1)
findurlpath = replace (urltmp ,"@@","//") & "/"
end function

function findurlhost (thisurl)
thisurl = replace (thisurl ,"//","@@")
ary_tmp = split (thisurl ,"/")
urltmp = ary_tmp (0)
findurlhost = replace (urltmp ,"@@","//") & "/"
findurlhost = left (findurlhost, len (findurlhost) -1)
end function


Asp and XML related Articles


Can't Find What You're Looking For?


Rating: Not yet rated

Comments

No comments posted.