This function can be used in collection or online addition of articles.
The code that saves remote images to the local device searched by myself on baidu is difficult to use and cannot be understood even if there is no ready-made full code.
I extracted the point function from the SNA News collection system For 3.62 (Program: ansir), which is relatively simple and easy to use.
The following are functions
Program code
Copy codeThe Code is as follows: <%
'================================================ ==============
'Function name: CheckDir2
'Usage: Check whether the folder exists
'Parameter: FolderPath ------ folder address
'================================================ ==============
Function CheckDir2 (byval FolderPath)
Dim fso
Folderpath = Server. MapPath (".") & "\" & folderpath
Set fso = Server. CreateObject ("Scripting. FileSystemObject ")
If fso. FolderExists (FolderPath) then
'Exist
CheckDir2 = True
Else
'Does not exist
CheckDir2 = False
End if
Set fso = nothing
End Function
'================================================ ==============
'Function name: MakeNewsDir2
'For use: create a new folder
'Parameter: foldername ------ folder name
'================================================ ==============
Function MakeNewsDir2 (byval foldername)
Dim fso
Set fso = Server. CreateObject ("Scripting. FileSystemObject ")
Fso. CreateFolder (Server. MapPath (".") & "\" & foldername)
If fso. FolderExists (Server. MapPath (".") & "\" & foldername) Then
MakeNewsDir2 = True
Else
MakeNewsDir2 = False
End If
Set fso = nothing
End Function
'================================================ ==============
'Function name: DefiniteUrl
'For use: Convert relative addresses to absolute addresses
'Parameter: PrimitiveUrl ------ relative address to be converted
'Parameter: ConsultUrl ------ current webpage address
'================================================ ==============
Function DefiniteUrl (Byval PrimitiveUrl, Byval ConsultUrl)
Dim ConTemp, PriTemp, Pi, Ci, PriArray, ConArray
If PrimitiveUrl = "" or ConsultUrl = "" or PrimitiveUrl = "$ False $" Then
DefiniteUrl = "$ False $"
Exit Function
End If
If Left (ConsultUrl, 7) <> "HTTP: //" And Left (ConsultUrl, 7) <> "http: //" Then
ConsultUrl = "http: //" & ConsultUrl
End If
ConsultUrl = Replace (ConsultUrl ,"://",":\\")
If Right (ConsultUrl, 1) <> "/" Then
If Instr (ConsultUrl, "/")> 0 Then
If Instr (Right (ConsultUrl, Len (ConsultUrl)-limit Rev (ConsultUrl, "/"), ".")> 0 then
Else
ConsultUrl = ConsultUrl &"/"
End If
Else
ConsultUrl = ConsultUrl &"/"
End If
End If
ConArray = Split (ConsultUrl ,"/")
If Left (PrimitiveUrl, 7) = "http: //" then
DefiniteUrl = Replace (PrimitiveUrl ,"://",":\\")
ElseIf Left (PrimitiveUrl, 1) = "/" Then
DefiniteUrl = ConArray (0) & PrimitiveUrl
ElseIf Left (PrimitiveUrl, 2) = "./" Then
DefiniteUrl = ConArray (0) & Right (PrimitiveUrl, Len (PrimitiveUrl)-1)
ElseIf Left (PrimitiveUrl, 3) = "../" then
Do While Left (PrimitiveUrl, 3) = "../"
PrimitiveUrl = Right (PrimitiveUrl, Len (PrimitiveUrl)-3)
Pi = Pi + 1
Loop
For Ci = 0 to (Ubound (ConArray)-1-Pi)
If DefiniteUrl <> "" Then
DefiniteUrl = DefiniteUrl & "/" & ConArray (Ci)
Else
DefiniteUrl = ConArray (Ci)
End If
Next
DefiniteUrl = DefiniteUrl & "/" & PrimitiveUrl
Else
If Instr (PrimitiveUrl, "/")> 0 Then
PriArray = Split (PrimitiveUrl ,"/")
If Instr (PriArray (0), ".")> 0 Then
If Right (PrimitiveUrl, 1) = "/" Then
DefiniteUrl = "http: \" & PrimitiveUrl
Else
If Instr (PriArray (Ubound (PriArray)-1), ".")> 0 Then
DefiniteUrl = "http: \" & PrimitiveUrl
Else
DefiniteUrl = "http: \" & PrimitiveUrl &"/"
End If
End If
Else
If Right (ConsultUrl, 1) = "/" Then
DefiniteUrl = ConsultUrl & PrimitiveUrl
Else
DefiniteUrl = Left (ConsultUrl, inclurev (ConsultUrl, "/") & PrimitiveUrl
End If
End If
Else
If Instr (PrimitiveUrl, ".")> 0 Then
If Right (ConsultUrl, 1) = "/" Then
If right (PrimitiveUrl, 3) = ". cn "or right (PrimitiveUrl, 3) =" com "or right (PrimitiveUrl, 3) =" net "or right (PrimitiveUrl, 3) =" org "Then
DefiniteUrl = "http: \" & PrimitiveUrl &"/"
Else
DefiniteUrl = ConsultUrl & PrimitiveUrl
End If
Else
If right (PrimitiveUrl, 3) = ". cn "or right (PrimitiveUrl, 3) =" com "or right (PrimitiveUrl, 3) =" net "or right (PrimitiveUrl, 3) =" org "Then
DefiniteUrl = "http: \" & PrimitiveUrl &"/"
Else
DefiniteUrl = Left (ConsultUrl, limit Rev (ConsultUrl, "/") & "/" & PrimitiveUrl
End If
End If
Else
If Right (ConsultUrl, 1) = "/" Then
DefiniteUrl = ConsultUrl & PrimitiveUrl &"/"
Else
DefiniteUrl = Left (ConsultUrl, inclurev (ConsultUrl, "/") & "/" & PrimitiveUrl &"/"
End If
End If
End If
End If
If Left (DefiniteUrl, 1) = "/" then
DefiniteUrl = Right (DefiniteUrl, Len (DefiniteUrl)-1)
End if
If DefiniteUrl <> "" Then
DefiniteUrl = Replace (DefiniteUrl ,"//","/")
DefiniteUrl = Replace (DefiniteUrl ,":\\","://")
Else
DefiniteUrl = "$ False $"
End If
End Function
'================================================ ==============
'Function name: ReplaceSaveRemoteFile
'For use: replace and save remote files
'Parameter: ConStr ------ string to be replaced
'Parameter: StarStr ----- leading
'Parameter: OverStr -----
'Parameter: IncluL ------
'Parameter: IncluR ------
'Parameter: SaveTf ------ whether to save the file; False: Not saved; True: Saved
'Parameter: SaveFilePath-save folder
'Parameter: TistUrl ------ current webpage address
'================================================ ==============
Function ReplaceSaveRemoteFile (ConStr, StartStr, OverStr, IncluL, IncluR, SaveTf, SaveFilePath, TistUrl)
If ConStr = "$ False $" or ConStr = "" Then
ReplaceSaveRemoteFile = "$ False $"
Exit Function
End If
Dim TempStr, TempStr2, ReF, Matches, Match, Tempi, TempArray, TempArray2, OverTypeArray
Set ReF = New Regexp
ReF. IgnoreCase = True
ReF. Global = True
ReF. Pattern = "(" & StartStr & "). +? ("& OverStr &")"
Set Matches = ReF. Execute (ConStr)
For Each Match in Matches
If Instr (TempStr, Match. Value) = 0 Then
If TempStr <> "" then
TempStr = TempStr & "$ Array $" & Match. Value
Else
TempStr = Match. Value
End if
End If
Next
Set Matches = nothing
Set ReF = nothing
If TempStr = "" or IsNull (TempStr) = True Then
ReplaceSaveRemoteFile = ConStr
Exit function
End if
If IncluL = False then
TempStr = Replace (TempStr, StartStr ,"")
End if
If IncluR = False then
If Instr (OverStr, "|")> 0 Then
OverTypeArray = Split (OverStr, "| ")
For Tempi = 0 To Ubound (OverTypeArray)
TempStr = Replace (TempStr, OverTypeArray (Tempi ),"")
Next
Else
TempStr = Replace (TempStr, OverStr ,"")
End If
End if
TempStr = Replace (TempStr ,"""","")
TempStr = Replace (TempStr ,"'","")
Dim RemoteFile, RemoteFileurl, SaveFileName, SaveFileType, ArrSaveFileName, RanNum
If Right (SaveFilePath, 1) = "/" then
SaveFilePath = Left (SaveFilePath, Len (SaveFilePath)-1)
End If
If SaveTf = True then
If CheckDir2 (SaveFilePath) = False Then
If MakeNewsDir2 (SaveFilePath) = False Then
SaveTf = False
End If
End If
End If
SaveFilePath = SaveFilePath &"/"
'Image conversion/saving
TempArray = Split (TempStr, "$ Array $ ")
For Tempi = 0 To Ubound (TempArray)
RemoteFileurl = DefiniteUrl (TempArray (Tempi), TistUrl)
If RemoteFileurl <> "$ False $" And SaveTf = True then' Save the image
ArrSaveFileName = Split (RemoteFileurl ,".")
SaveFileType = ArrSaveFileName (Ubound (ArrSaveFileName) 'file type
RanNum = Int (900 * Rnd) + 100
SaveFileName = SaveFilePath & year (now) & month (now) & day (now) & hour (now) & minute (now) & second (now) & ranNum &". "& SaveFileType
Call SaveRemoteFile (SaveFileName, RemoteFileurl)
ConStr = Replace (ConStr, TempArray (Tempi), SaveFileName)
ElseIf RemoteFileurl <> "$ False $" and SaveTf = False then' do not save the image
SaveFileName = RemoteFileUrl
ConStr = Replace (ConStr, TempArray (Tempi), SaveFileName)
End If
If RemoteFileUrl <> "$ False $" Then
If UploadFiles = "" then
UploadFiles = SaveFileName
Else
UploadFiles = UploadFiles & "|" & SaveFileName
End if
End If
Next
ReplaceSaveRemoteFile = ConStr
End function
'================================================ ==============
'Process name: SaveRemoteFile
'Usage: Save the remote file to the local device.
'Parameter: LocalFileName ------ local file name
'Parameter: RemoteFileUrl ------ Remote File URL
'================================================ ==============
Sub SaveRemoteFile (LocalFileName, RemoteFileUrl)
Dim Ads, Retrieval, GetRemoteData
Set Retrieval = Server. CreateObject ("Microsoft. XMLHTTP ")
With Retrieval
. Open "Get", RemoteFileUrl, False ,"",""
. Send
GetRemoteData =. ResponseBody
End
Set Retrieval = Nothing
Set Ads = Server. CreateObject ("Adodb. Stream ")
With Ads
. Type = 1
. Open
. Write GetRemoteData
. SaveToFile server. MapPath (LocalFileName), 2
. Cancel ()
. Close ()
End
Set Ads = nothing
End sub
'================================================ ==============
'Process name: GetImg
'Usage: Get the first image in the article
'Parameter: str ------ content of the article
'Parameter: strpath ------ path for saving the image
'================================================ ==============
Function GetImg (str, strpath)
Set objregEx = new RegExp
ObjregEx. IgnoreCase = true
ObjregEx. Global = true
Zzstr = "" & strpath & "(. + ?) \. (Jpg | gif | png | bmp )"
ObjregEx. Pattern = zzstr
Set matches = objregEx.exe cute (str)
For each match in matches
Retstr = retstr & "|" & Match. Value
Next
If retstr <> "" then
Imglist = split (retstr, "| ")
Imgone = replace (Imglist (1), strpath ,"")
GetImg = Imgone
Else
GetImg = ""
End if
End function
%>
The following is an example
Program codeCopy codeThe Code is as follows: <form id = "form1" name = "form1" method = "post" action = "? Action = test ">
<Textarea name = "body" cols = "50" rows = "5" id = "body">
</Textarea>
<Input type = "submit" name = "Submit" value = "submit"/>
</Form>
<%
If request. QueryString ("action") = "test" then
'Image start string
FilesStartStr = "src ="
'Image end string
FilesOverStr = "gif | jpg | bmp"
'Save the image folder
FilesPath = "qq"
'Get the website URL to save the image and automatically determine whether the URL is absolute or relative. In this example, the image is an absolute address. Therefore, NEWURL is useless. If it is ../images/123.gif, NEWURL needs to be specified.
NewsUrl = "http://news.163.com"
'Get the article content
Content = Request. Form ("body ")
'Start saving the image
Content = ReplaceSaveRemoteFile (Content, FilesStartStr, FilesOverStr, False, True, True, FilesPath, NewsUrl)
'Create a thumbnail for the first image in the news
If GetImg (Content, FilesPath) <> "" then
Imgsrc = GetImg (Content, FilesPath)
Imgsrc = replace (Imgsrc, FilesPath ,"")
Set Jpeg = Server. CreateObject ("Persits. Jpeg ")
Path = Server. MapPath ("" & FilesPath & "") & "\" & Imgsrc &""
Jpeg. Open Path
'If the image width is less than or equal to 120, and the height is less than or equal to 90, no thumbnail is created.
If Jpeg. OriginalWidth <= 120 and Jpeg. Height <= 90 then
Jpeg. Width = Jpeg. OriginalWidth
Jpeg. Height = Jpeg. OriginalHeight
Smallimg = FilesPath & "& GetImg (Content, FilesPath)
Else
'Image width and height/2
Jpeg. Width = Jpeg. OriginalWidth/2
Jpeg. Height = Jpeg. OriginalHeight/2
Jpeg. Save Server. MapPath ("" & FilesPath & "") & "\ small _" & Imgsrc &""
Smallimg = "" & FilesPath & "/small _" & Imgsrc &""
End if
End if
'Display result
Response. Write ("the first picture in the news is :")
Response. Write (" ")
Response. Write ("<br> the thumbnail of the first image in the news is :")
Response. Write (" ")
Response. Write ("<br> new news content (picture is local): <br> ")
Response. Write (Content)
Response. End ()
End if
%>
