ASP save remote picture to local and get first picture at the same time

This is a few functions I used in the SNA News collection system for power 3.62
Can be commonly used in collecting or adding articles online
Here is the function program code
<%
'==================================================
' Function name: Definiteurl
' Function: Converts a relative address to an absolute address
' Parameter: Primitiveurl------The relative address to convert
' Parameter: Consulturl------Current page 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 (Consulturl,len (Consulturl)-instrrev (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,instrrev (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,instrrev (Consulturl, "/")) & "/" & Primitiveurl
End If
End If
Else
If Right (consulturl,1) = "/" Then
Definiteurl=consulturl & Primitiveurl & "/"
Else
Definiteurl=left (Consulturl,instrrev (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
' Function: Replace, save remote file
' Parameter: constr------The string to replace
' Parameters: Starstr-----Leading
' Parameters: Overstr-----
' Parameters: Inclul------
' Parameters: Inclur------
' Parameter: SAVETF------Whether to save the file, False not save, true save
' Parameter: savefilepath-Save folder
' Parameter: Tisturl------Current page 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 the 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 & "/"

' Picture conversion/Save
Temparray=split (TempStr, "$Array $")
For tempi=0 to Ubound (Temparray)
Remotefileurl=definiteurl (Temparray (tempi), Tisturl)
If remotefileurl<> "$False $" and savetf=true Then ' save picture
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) &ranNum& "." &savefiletype
Call Saveremotefile (Savefilename,remotefileurl)
Constr=replace (Constr,temparray (tempi), savefilename)
ElseIf remotefileurl<> "$False $" and savetf=false Then ' do not save pictures
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
'==================================================
' Procedure name: Saveremotefile
' Function: Save remote files to local
' Parameter: localfilename------local filename
' 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 With
Set retrieval = Nothing
Set Ads = Server.CreateObject ("ADODB.stream")
With Ads
. Type = 1
. Open
. Write Getremotedata
. SaveToFile server. MapPath (LocalFilename), 2
. Cancel ()
. Close ()
End With
Set ads=nothing
End Sub

'==================================================
' Procedure name: getimg
' function: Get the first picture in the article
' Parameters: str------article content
' Parameter: strpath------Save the path to the picture
'==================================================
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.execute (str)
For the 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

'==================================================
' Function name: CHECKDIR2
' Function: Check if 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
' Existence
CheckDir2 = True
Else
' does not exist
CheckDir2 = False
End If
Set FSO = Nothing
End Function
'==================================================
' Function name: MAKENEWSDIR2
' Function: Create a new Folder
' Parameters: 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

%>