This article provides a complete set of ASP collection functions, including functions such as extracting the original characters of the address, saving remote files to local simulated login, and obtaining web page source code.
Copy the code code as follows:
'================================================== =
'Function name: GetHttpPage
'Function: Get the source code of the web page
'Parameter: HttpUrl ------Web page address
'================================================== =
Function GetHttpPage(HttpUrl)
If IsNull(HttpUrl)=True Or Len(HttpUrl)<18 Or HttpUrl="$False$" Then
GetHttpPage="$False$"
Exit Function
End If
Dim Http
Set Http=server.createobject("MSX" & "ML2.XM" & "LHT" & "TP")
Http.open "GET",HttpUrl,False
Http.Send()
If Http.Readystate<>4 then
Set Http=Nothing
GetHttpPage="$False$"
Exit function
End if
GetHTTPPage=bytesToBSTR(Http.responseBody,"GB2312")
GetHTTPPage=replace(replace(GetHTTPPage , vbCr,""),vbLf,"")
Set Http=Nothing
If Err.number<>0 then
Err.Clear
End If
End Function
'================================================== =
'Function name: BytesToBstr
'Function: Convert the obtained source code into Chinese
'Parameter: Body ------Variable to be converted
'Parameter: Cset ------type to be converted
'================================================== =
Function BytesToBstr(Body,Cset)
Dim Objstream
Set Objstream = Server.CreateObject("ad" & "odb.str" & "eam")
objstream.Type = 1
objstream.Mode =3
objstream.Open
objstream.Write body
objstream.Position = 0
objstream.Type = 2
objstream.Charset = Cset
BytesToBstr = objstream.ReadText
objstream.Close
set objstream = nothing
End Function
'================================================== =
'Function name: PostHttpPage
'Function: login
'================================================== =
Function PostHttpPage(RefererUrl,PostUrl,PostData)
DimxmlHttp
DimRetStr
Set xmlHttp = CreateObject("Msx" & "ml2.XM" & "LHT" & "TP")
xmlHttp.Open "POST", PostUrl, False
XmlHTTP.setRequestHeader "Content-Length",Len(PostData)
xmlHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
xmlHttp.setRequestHeader "Referer", RefererUrl
xmlHttp.Send PostData
If Err.Number <> 0 Then
Set xmlHttp=Nothing
PostHttpPage = "$False$"
Exit Function
End If
PostHttpPage=bytesToBSTR(xmlHttp.responseBody,"GB2312")
Set xmlHttp = nothing
End Function
'================================================== =
'Function name: UrlEncoding
'Function: Convert encoding
'================================================== =
Function UrlEncoding(DataStr)
Dim StrReturn,Si,ThisChr,InnerCode,Hight8,Low8
StrReturn = ""
For Si = 1 To Len(DataStr)
ThisChr = Mid(DataStr,Si,1)
If Abs(Asc(ThisChr)) < &HFF Then
StrReturn = StrReturn & ThisChr
Else
InnerCode = Asc(ThisChr)
If InnerCode < 0 Then
InnerCode = InnerCode + &H10000
End If
Hight8 = (InnerCode And &HFF00)/ &HFF
Low8 = InnerCode And &HFF
StrReturn = StrReturn & "%" & Hex(Hight8) & "%" & Hex(Low8)
End If
Next
UrlEncoding = StrReturn
End Function
'================================================== =
'Function name: GetBody
'Function: intercept string
'Parameter: ConStr ------The string to be intercepted
'Parameter: StartStr ------start string
'Parameter: OverStr ------End string
'Parameter: IncluL ------Whether StartStr is included
'Parameter:IncluR ------whether to include OverStr
'================================================== =
Function GetBody(ConStr,StartStr,OverStr,IncluL,IncluR)
If ConStr="$False$" or ConStr="" or IsNull(ConStr)=True Or StartStr="" or IsNull(StartStr)=True Or OverStr="" or IsNull(OverStr)=True Then
GetBody="$False$"
Exit Function
End If
DimConStrTemp
Dim Start,Over
ConStrTemp=Lcase(ConStr)
StartStr=Lcase(StartStr)
OverStr=Lcase(OverStr)
Start = InStrB(1, ConStrTemp, StartStr, vbBinaryCompare)
If Start<=0 then
GetBody="$False$"
Exit Function
Else
If IncluL=False Then
Start=Start+LenB(StartStr)
End If
End If
Over=InStrB(Start,ConStrTemp,OverStr,vbBinaryCompare)
If Over<=0 Or Over<=Start then
GetBody="$False$"
Exit Function
Else
If InclR=True Then
Over=Over+LenB(OverStr)
End If
End If
GetBody=MidB(ConStr,Start,Over-Start)
End Function
'================================================== =
'Function name: GetArray
'Function: Extract the link address, separated by $Array$
'Parameter: ConStr ------Extract the original characters of the address
'Parameter: StartStr ------start string
'Parameter: OverStr ------End string
'Parameter: IncluL ------Whether StartStr is included
'Parameter:IncluR ------whether to include OverStr
'================================================== =
Function GetArray(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
If ConStr="$False$" or ConStr="" Or IsNull(ConStr)=True or StartStr="" Or OverStr="" or IsNull(StartStr)=True Or IsNull(OverStr)=True Then
GetArray="$False$"
Exit Function
End If
Dim TempStr,TempStr2,objRegExp,Matches,Match
TempStr=""
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "("&StartStr&").+?("&OverStr&")"
Set Matches =objRegExp.Execute(ConStr)
For Each Match in Matches
TempStr=TempStr & "$Array$" & Match.Value
Next
Set Matches=nothing
If TempStr="" Then
GetArray="$False$"
Exit Function
End If
TempStr=Right(TempStr,Len(TempStr)-7)
If IncluL=False then
objRegExp.Pattern =StartStr
TempStr=objRegExp.Replace(TempStr,"")
End if
If InclR=False then
objRegExp.Pattern =OverStr
TempStr=objRegExp.Replace(TempStr,"")
End if
Set objRegExp=nothing
Set Matches=nothing
TempStr=Replace(TempStr,"""","")
TempStr=Replace(TempStr,"'","")
TempStr=Replace(TempStr," ","")
TempStr=Replace(TempStr,"(","")
TempStr=Replace(TempStr,")","")
If TempStr="" then
GetArray="$False$"
Else
GetArray=TempStr
End if
End Function
'================================================== =
'Function name: DefiniteUrl
'Function: Convert relative address to absolute address
'Parameter: PrimitiveUrl ------ relative address to be converted
'Parameter: ConsultUrl ------Current web page address
'================================================== =
Function DefiniteUrl(Byval PrimitiveUrl,Byval ConsultUrl)
Dim ConTemp,PriTemp,Pi,Ci,PriArray,ConArray
If PrimitiveUrl="" or ConsultUrl="" or PrimitiveUrl="$False$" or ConsultUrl="$False$" Then
DefiniteUrl="$False$"
Exit Function
End If
If Left(Lcase(ConsultUrl),7)<>"http://" Then
ConsultUrl= "http://" & ConsultUrl
End If
ConsultUrl=Replace(ConsultUrl,"/","/")
ConsultUrl=Replace(ConsultUrl,"://","://")
PrimitiveUrl=Replace(PrimitiveUrl,"/","/")
If Right(ConsultUrl,1)<>"/" Then
If Instr(ConsultUrl,"/")>0 Then
If Instr(Right(ConsultUrl,Len(ConsultUrl)-InstrRev(ConsultUrl,"/")),".")>0 then
Else
ConsultUrl=ConsultUrl & "/"
End If
Else
ConsultUrl=ConsultUrl & "/"
End If
End If
ConArray=Split(ConsultUrl,"/")
If Left(LCase(PrimitiveUrl),7) = "http://" then
DefiniteUrl=Replace(PrimitiveUrl,"://","://")
ElseIf Left(PrimitiveUrl,1) = "/" Then
DefiniteUrl=ConArray(0) & PrimitiveUrl
ElseIf Left(PrimitiveUrl,2)="./" Then
PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-2)
If Right(ConsultUrl,1)="/" Then
DefiniteUrl=ConsultUrl & PrimitiveUrl
Else
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl
End If
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(LCase(PrimitiveUrl),3)=".cn" or right(LCase(PrimitiveUrl),3)="com" or right(LCase(PrimitiveUrl),3)="net" or right(LCase(PrimitiveUrl) ,3)="org" Then
DefiniteUrl="http://" & PrimitiveUrl & "/"
Else
DefiniteUrl=ConsultUrl & PrimitiveUrl
End If
Else
If right(LCase(PrimitiveUrl),3)=".cn" or right(LCase(PrimitiveUrl),3)="com" or right(LCase(PrimitiveUrl),3)="net" or right(LCase(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 and save remote pictures
'Parameter: ConStr ------ string to be replaced
'Parameter: SaveTf ------ Whether to save the file, False does not save, True saves
'Parameter: TistUrl------ current web page address
'================================================== =
Function ReplaceSaveRemoteFile(ConStr,InstallPath,strChannelDir,SaveTf,TistUrl)
If ConStr="$False$" or ConStr="" or InstallPath="" or strChannelDir="" Then
ReplaceSaveRemoteFile=ConStr
Exit Function
End If
Dim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2
Set Re = New Regexp
Re.IgnoreCase = True
Re.Global = True
Re.Pattern ="<img.+?>"
Set Matches =Re.Execute(ConStr)
For Each Match in Matches
If TempStr<>"" then
TempStr=TempStr & "$Array$" & Match.Value
Else
TempStr=Match.Value
End if
Next
If TempStr<>"" Then
TempArray=Split(TempStr,"$Array$")
TempStr=""
For Tempi=0 To Ubound(TempArray)
Re.Pattern ="src/s*=/s*.+?/.(gifjpgbmpjpegpsdpngsvgdxfwmftiff)"
Set Matches =Re.Execute(TempArray(Tempi))
For Each Match in Matches
If TempStr<>"" then
TempStr=TempStr & "$Array$" & Match.Value
Else
TempStr=Match.Value
End if
Next
Next
End if
If TempStr<>"" Then
Re.Pattern ="src/s*=/s*"
TempStr=Re.Replace(TempStr,"")
End If
Set Matches=nothing
Set Re=nothing
If TempStr="" or IsNull(TempStr)=True Then
ReplaceSaveRemoteFile=ConStr
Exit function
End if
TempStr=Replace(TempStr,"""","")
TempStr=Replace(TempStr,"'","")
TempStr=Replace(TempStr," ","")
Dim RemoteFileurl,SavePath,PathTemp,DtNow,strFileName,strFileType,ArrSaveFileName,RanNum,Arr_Path
DtNow=Now()
'**********************************
If SaveTf=True then
SavePath=InstallPath&strChannelDir
If CheckDir(InstallPath & strChannelDir)=False Then
If Not CreateMultiFolder(InstallPath & strChannelDir) Then
response.Write InstallPath & strChannelDir&"Directory creation failed"
SaveTf=False
End If
End If
End If
'Start by removing duplicate images
TempArray=Split(TempStr,"$Array$")
TempStr=""
For Tempi=0 To Ubound(TempArray)
If Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Then
TempStr=TempStr & "$Array$" & TempArray(Tempi)
End If
Next
TempStr=Right(TempStr,Len(TempStr)-7)
TempArray=Split(TempStr,"$Array$")
'Remove duplicate images and end
response.Write "<br>Picture found:<br>"&Replace(TempStr,"$Array$","<br>")
'Start converting relative image addresses
TempStr=""
For Tempi=0 To Ubound(TempArray)
TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)
Next
TempStr=Right(TempStr,Len(TempStr)-7)
TempStr=Replace(TempStr,Chr(0),"")
TempArray2=Split(TempStr,"$Array$")
TempStr=""
'End of converting relative image address
'Picture replacement/save
Set Re = New Regexp
Re.IgnoreCase = True
Re.Global = True
For Tempi=0 To Ubound(TempArray2)
'**********************************
RemoteFileUrl=TempArray2(Tempi)
If RemoteFileUrl<>"$False$" And SaveTf=True Then'Save the picture
ArrSaveFileName = Split(RemoteFileurl,".")
strFileType=Lcase(ArrSaveFileName(Ubound(ArrSaveFileName)))'File type
If strFileType="asp" or strFileType="asa" or strFileType="aspx" or strFileType="cer" or strFileType="cdx" or strFileType="exe" or strFileType="rar" or strFileType="zip" then
UploadFiles=""
ReplaceSaveRemoteFile=ConStr
Exit Function
End If
Randomize
RanNum=Int(900*Rnd)+100
strFileName = year(DtNow) & right("0" & month(DtNow),2) & right("0" & day(DtNow),2) & right("0" & hour(DtNow),2) & right ("0" & minute(DtNow),2) & right("0" & second(DtNow),2) & ranNum & "." & strFileType
Re.Pattern =TempArray(Tempi)
response.Write "<br>Save to local address:"&InstallPath & strChannelDir & strFileName
If SaveRemoteFile(InstallPath & strChannelDir & strFileName,RemoteFileUrl,RemoteFileUrl)=True Then
response.Write "<font color=blue>Success</font><br>"
PathTemp=InstallPath & strChannelDir & strFileName
ConStr=Re.Replace(ConStr,PathTemp)
Re.Pattern=InstallPath&strChannelDir
UploadFiles=UploadFiles & "" & InstallPath & strChannelDir & strFileName
Else
PathTemp=RemoteFileUrl
ConStr=Re.Replace(ConStr,PathTemp)
End If
ElseIf RemoteFileurl<>"$False$" and SaveTf=False Then'Do not save the image
Re.Pattern =TempArray(Tempi)
ConStr=Re.Replace(ConStr,RemoteFileUrl)
End If
'************************************
Next
Set Re=nothing
ReplaceSaveRemoteFile=ConStr
End function
'================================================== =
'Function name: ReplaceSwfFile
'Function: parse animation path
'Parameter: ConStr ------ string to be replaced
'Parameter: TistUrl------ current web page address
'================================================== =
Function ReplaceSwfFile(ConStr,TistUrl)
If ConStr="$False$" or ConStr="" or TistUrl="" or TistUrl="$False$" Then
ReplaceSwfFile=ConStr
Exit Function
End If
Dim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2
Set Re = New Regexp
Re.IgnoreCase = True
Re.Global = True
Re.Pattern ="<object.+?[^/>]>"
Set Matches =Re.Execute(ConStr)
For Each Match in Matches
If TempStr<>"" then
TempStr=TempStr & "$Array$" & Match.Value
Else
TempStr=Match.Value
End if
Next
If TempStr<>"" Then
TempArray=Split(TempStr,"$Array$")
TempStr=""
For Tempi=0 To Ubound(TempArray)
Re.Pattern ="value/s*=/s*.+?/.swf"
Set Matches =Re.Execute(TempArray(Tempi))
For Each Match in Matches
If TempStr<>"" then
TempStr=TempStr & "$Array$" & Match.Value
Else
TempStr=Match.Value
End if
Next
Next
End if
If TempStr<>"" Then
Re.Pattern ="value/s*=/s*"
TempStr=Re.Replace(TempStr,"")
End If
If TempStr="" or IsNull(TempStr)=True Then
ReplaceSwfFile=ConStr
Exit function
End if
TempStr=Replace(TempStr,"""","")
TempStr=Replace(TempStr,"'","")
TempStr=Replace(TempStr," ","")
Set Matches=nothing
Set Re=nothing
'Start by removing duplicate files
TempArray=Split(TempStr,"$Array$")
TempStr=""
For Tempi=0 To Ubound(TempArray)
If Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Then
TempStr=TempStr & "$Array$" & TempArray(Tempi)
End If
Next
TempStr=Right(TempStr,Len(TempStr)-7)
TempArray=Split(TempStr,"$Array$")
'Remove duplicate files and end
'Start converting relative addresses
TempStr=""
For Tempi=0 To Ubound(TempArray)
TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)
Next
TempStr=Right(TempStr,Len(TempStr)-7)
TempStr=Replace(TempStr,Chr(0),"")
TempArray2=Split(TempStr,"$Array$")
TempStr=""
'End of converting relative address
'replace
Set Re = New Regexp
Re.IgnoreCase = True
Re.Global = True
For Tempi=0 To Ubound(TempArray2)
RemoteFileUrl=TempArray2(Tempi)
Re.Pattern =TempArray(Tempi)
ConStr=Re.Replace(ConStr,RemoteFileUrl)
Next
Set Re=nothing
ReplaceSwfFile=ConStr
End function
'================================================== =
'Process name: SaveRemoteFile
'Function: save remote files to local
'Parameter: LocalFileName ------ local file name
'Parameter: RemoteFileUrl ------ Remote file URL
'Parameter: Referer ------ Remote call file (for anti-collection, use the content page address, leave it blank if there is no anti-collection)
'================================================== =
Function SaveRemoteFile(LocalFileName,RemoteFileUrl,Referer)
SaveRemoteFile=True
dim Ads,Retrieval,GetRemoteData
Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
With Retrieval
.Open "Get", RemoteFileUrl, False, "", ""
if Referer<>"" then .setRequestHeader "Referer",Referer
.Send
If .Readystate<>4 then
SaveRemoteFile=False
Exit Function
End If
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 Function
'================================================== =
'Function name: GetPaing
'Function: Get pagination
'================================================== =
Function GetPaing(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
If ConStr="$False$" or ConStr="" Or StartStr="" Or OverStr="" or IsNull(ConStr)=True or IsNull(StartStr)=True Or IsNull(OverStr)=True Then
GetPaing="$False$"
Exit Function
End If
Dim Start,Over,ConTemp,TempStr
TempStr=LCase(ConStr)
StartStr=LCase(StartStr)
OverStr=LCase(OverStr)
Over=Instr(1,TempStr,OverStr)
If Over<=0 Then
GetPaing="$False$"
Exit Function
Else
If InclR=True Then
Over=Over+Len(OverStr)
End If
End If
TempStr=Mid(TempStr,1,Over)
Start=InstrRev(TempStr,StartStr)
If IncluL=False Then
Start=Start+Len(StartStr)
End If
If Start<=0 Or Start>=Over Then
GetPaing="$False$"
Exit Function
End If
ConTemp=Mid(ConStr,Start,Over-Start)
ConTemp=Trim(ConTemp)
'ConTemp=Replace(ConTemp," ","")
ConTemp=Replace(ConTemp,",","")
ConTemp=Replace(ConTemp,"'","")
ConTemp=Replace(ConTemp,"""","")
ConTemp=Replace(ConTemp,">","")
ConTemp=Replace(ConTemp,"<","")
ConTemp=Replace(ConTemp," ;","")
GetPaing=ConTemp
End Function
'************************************************
'Function name: gotTopic
'Function: truncate the string, each Chinese character counts as two characters, and the English character counts as one character
'Parameter: str ---- original string
' strlen ---- intercept length
'Return value: intercepted string
'************************************************
function gotTopic(str,strlen)
if str="" then
gotTopic=""
exit function
end if
dim l,t,c,i
str=replace(replace(replace(replace(str," "," "),""",chr(34)),">",">"),"<","<")
l=len(str)
t=0
for i=1 to l
c=Abs(Asc(Mid(str,i,1)))
if c>255 then
t=t+2
else
t=t+1
end if
if t>=strlen then
gotTopic=left(str,i) & "…"
exit for
else
gotTopic=str
end if
next
gotTopic=replace(replace(replace(replace(gotTopic," "," "),chr(34),"""),">",">"),"<","<;")
end function
'**********************************************
'Function name: JoinChar
'Function: Add ? or & to the address
'Parameter: strUrl ---- URL
'Return value: URL with ? or & added
'**********************************************
function JoinChar(strUrl)
if strUrl="" then
JoinChar=""
exit function
end if
if InStr(strUrl,"?")<len(strUrl) then
if InStr(strUrl,"?")>1 then
if InStr(strUrl,"&")<len(strUrl) then
JoinChar=strUrl & "&"
else
JoinChar=strUrl
end if
else
JoinChar=strUrl & "?"
end if
else
JoinChar=strUrl
end if
end function
'************************************************ *
'Function name: CreateKeyWord
'Function: Generate keywords from the given string
'Parameter: Constr---the original string to generate the keyword
'Return value: generated keyword
'************************************************ *
Function CreateKeyWord(byval Constr,Num)
If Constr="" or IsNull(Constr)=True or Constr="$False$" Then
CreateKeyWord="$False$"
Exit Function
End If
If Num="" or IsNumeric(Num)=False Then
Num=2
End If
Constr=Replace(Constr,CHR(32),"")
Constr=Replace(Constr,CHR(9),"")
Constr=Replace(Constr," ","")
Constr=Replace(Constr," ","")
Constr=Replace(Constr,"(","")
Constr=Replace(Constr,")","")
Constr=Replace(Constr,"<","")
Constr=Replace(Constr,">","")
Constr=Replace(Constr,"""","")
Constr=Replace(Constr,"?","")
Constr=Replace(Constr,"*","")
Constr=Replace(Constr,"","")
Constr=Replace(Constr,",","")
Constr=Replace(Constr,".","")
Constr=Replace(Constr,"/","")
Constr=Replace(Constr,"/","")
Constr=Replace(Constr,"-","")
Constr=Replace(Constr,"@","")
Constr=Replace(Constr,"#","")
Constr=Replace(Constr,"$","")
Constr=Replace(Constr,"%","")
Constr=Replace(Constr,"&","")
Constr=Replace(Constr,"+","")
Constr=Replace(Constr,":","")
Constr=Replace(Constr,"：","")
Constr=Replace(Constr,"'","")
Constr=Replace(Constr,""","")
Constr=Replace(Constr,""","")
Dim i,ConstrTemp
For i=1 To Len(Constr)
ConstrTemp=ConstrTemp & "" & Mid(Constr,i,Num)
Next
If Len(ConstrTemp)<254 Then
ConstrTemp=ConstrTemp & ""
Else
ConstrTemp=Left(ConstrTemp,254) & ""
End If
CreateKeyWord=ConstrTemp
End Function
'================================================== =
'Function name: CheckUrl
'Function: Check Url
'Parameter: strUrl ------ To check Url
'================================================== =
Function CheckUrl(strUrl)
Dim Re
Set Re=new RegExp
Re.IgnoreCase=true
Re.Global=True
Re.Pattern="http://([/w-]+/.)+[/w-]+(/[/w-./?%&=]*)?"
If Re.test(strUrl)=True Then
CheckUrl=strUrl
Else
CheckUrl="$False$"
End If
Set Rs=Nothing
End Function
'================================================== =
'Function name: ScriptHtml
'Function: filter html tags
'Parameter: ConStr ------ The string to be filtered
'================================================== =
Function ScriptHtml(Byval ConStr,TagName,FType)
Dim Re
Set Re=new RegExp
Re.IgnoreCase=true
Re.Global=True
Select Case FType
Case 1
Re.Pattern="<" & TagName & "([^>])*>"
ConStr=Re.Replace(ConStr,"")
Case 2
Re.Pattern="<" & TagName & "([^>])*>.*?</" & TagName & "([^>])*>"
ConStr=Re.Replace(ConStr,"")
Case 3
Re.Pattern="<" & TagName & "([^>])*>"
ConStr=Re.Replace(ConStr,"")
Re.Pattern="</" & TagName & "([^>])*>"
ConStr=Re.Replace(ConStr,"")
End Select
ScriptHtml=ConStr
Set Re=Nothing
End Function
'================================================== =
'Function name: RemoveHTML
'Function: Completely remove html tags
'Parameter: strHTML ------ The string to be filtered
'================================================== =
Function RemoveHTML(strHTML)
Dim objRegExp, Match, Matches
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
'Get the closed <>
objRegExp.Pattern = "<.+?>"
'Match
Set Matches = objRegExp.Execute(strHTML)
' Traverse the matching set and replace matching items
For Each Match in Matches
strHtml=Replace(strHTML,Match.Value,"")
Next
RemoveHTML=strHTML
Set objRegExp = Nothing
End Function
'================================================== =
'Function name: CheckDir
'Function: Check whether the folder exists
'Parameter: FolderPath ------ folder path
'================================================== =
Function CheckDir(byval FolderPath)
dim fso
Set fso = Server.CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(Server.MapPath(folderpath)) then
'exist
CheckDir = True
Else
'does not exist
CheckDir = False
End if
Set fso = nothing
End Function
'================================================== =
'Function name: MakeNewsDir
'Function: Create a folder
'Parameter: foldername ------ folder name
'================================================== =
Function MakeNewsDir(byval foldername)
dim fso
Set fso = Server.CreateObject("Scri" & "pti" & "ng.Fil" & "eSyst" & "emOb" & "ject")
fso.CreateFolder(Server.MapPath(foldername))
If fso.FolderExists(Server.MapPath(foldername)) Then
MakeNewsDir = True
Else
MakeNewsDir = False
End If
Set fso = nothing
End Function
'================================================== =
'Function name: DelDir
'Function: Create a folder
'Parameter: foldername ------ folder name
'================================================== =
Function DelDir(byval foldername)
dim fso
Set fso = Server.CreateObject("Scri" & "pti" & "ng.Fil" & "eSyst" & "emOb" & "ject")
If fso.FolderExists(Server.MapPath(foldername)) Then 'Determine whether the folder exists
fso.DeleteFolder (Server.MapPath(foldername)) 'Delete folder
End If
Set fso = nothing
End Function
'************************************************ *
'Function name: IsObjInstalled
'Function: Check whether the component has been installed
'Parameter: strClassString ---- component name
'Return value: True ---- Already installed
' False ---- not installed
'************************************************ *
Function IsObjInstalled(strClassString)
IsObjInstalled = False
Err = 0
DimxTestObj
Set xTestObj = Server.CreateObject(strClassString)
If 0 = Err Then IsObjInstalled = True
Set xTestObj = Nothing
Err = 0
End Function
'************************************************ *
'Function name: strLength
'Function: Find the length of the string. Chinese characters count as two characters, and English characters count as one character.
'Parameter: str ----String with required length
'Return value: string length
'************************************************ *
function strLength(str)
ON ERROR RESUME NEXT
dim WINNT_CHINESE
WINNT_CHINESE = (len("China")=2)
if WINNT_CHINESE then
dim l,t,c
dim i
l=len(str)
t=l
for i=1 to l
c=asc(mid(str,i,1))
if c<0 then c=c+65536
if c>255 then
t=t+1
end if
next
strLength=t
else
strLength=len(str)
end if
if err.number<>0 then err.clear
end function
'************************************************ ***
'Function name: CreateMultiFolder
'Function: Create multi-level directories, you can create non-existent root directories
'Parameter: the name of the directory to be created, which can be multi-level
'Return logical value: True on success, False on failure
'Create the root directory of the directory starting from the current directory
'************************************************ ***
Function CreateMultiFolder(ByVal CFolder)
Dim objFSO,PhCreateFolder,CreateFolderArray,CreateFolder
Dim i,ii,CreateFolderSub,PhCreateFolderSub,BlInfo
BlInfo=False
CreateFolder = CFolder
On Error Resume Next
Set objFSO = Server.CreateObject("Scri" & "pti" & "ng.Fil" & "eSyst" & "emOb" & "ject")
If Err Then
Err.Clear()
Exit Function
End If
CreateFolder = Replace(CreateFolder,"/","/")
If Left(CreateFolder,1)="/" Then
'CreateFolder = Right(CreateFolder,Len(CreateFolder)-1)
End If
If Right(CreateFolder,1)="/" Then
CreateFolder = Left(CreateFolder,Len(CreateFolder)-1)
End If
CreateFolderArray = Split(CreateFolder,"/")
For i = 0 to UBound(CreateFolderArray)
CreateFolderSub = ""
For ii = 0 to i
CreateFolderSub = CreateFolderSub & CreateFolderArray(ii) & "/"
Next
PhCreateFolderSub = Server.MapPath(CreateFolderSub)
'response.Write PhCreateFolderSub&"<br>"
If Not objFSO.FolderExists(PhCreateFolderSub) Then
objFSO.CreateFolder(PhCreateFolderSub)
End If
Next
If Err Then
Err.Clear()
Else
BlInfo=True
End If
Set objFSO=nothing
CreateMultiFolder = BlInfo
End Function
'************************************************ *
'Function name: FSOFileRead
'Function: Use FSO to read the file content function
'Parameter: filename ---- file name
'Return value: file content
'************************************************ *
function FSOFileRead(filename)
Dim objFSO,objCountFile,FiletempData
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objCountFile = objFSO.OpenTextFile(Server.MapPath(filename),1,True)
FSOFileRead = objCountFile.ReadAll
objCountFile.Close
Set objCountFile=Nothing
Set objFSO = Nothing
End Function
'************************************************ *
'Function name: FSOlinedit
'Function: Use FSO to read a certain line of the file function
'Parameter: filename ---- file name
' lineNum ---- line number
'Return value: the content of the line in the file
'************************************************ *
function FSOlinedit(filename,lineNum)
if linenum < 1 then exit function
dim fso,f,temparray,tempcnt
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.AtEndofStream then
tempcnt = f.readall
f.close
set f = nothing
temparray = split(tempcnt,chr(13)&chr(10))
if lineNum>ubound(temparray)+1 then
exit function
else
FSOlinedit = temparray(lineNum-1)
end if
end if
end function
'************************************************ *
'Function name: FSOlinewrite
'Function: Use FSO to write a certain line of the file function
'Parameter: filename ---- file name
' lineNum ----line number
' Linecontent ---- content
'Return value: None
'************************************************ *
function FSOlinewrite(filename,lineNum,Linecontent)
if linenum < 1 then exit function
dim fso,f,temparray,tempCnt
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.AtEndofStream then
tempcnt = f.readall
f.close
temparray = split(tempcnt,chr(13)&chr(10))
if lineNum>ubound(temparray)+1 then
exit function
else
temparray(lineNum-1) = lineContent
end if
tempcnt = join(temparray,chr(13)&chr(10))
set f = fso.createtextfile(server.mappath(filename),true)
f.writetempcnt
end if
f.close
set f = nothing
end function
'************************************************ *
'Function name: Htmlmake
'Function: Use FSO to create files
'Parameter: HtmlFolder ---- path
' HtmlFilename ---- file name
'HtmlContent ----Content
'************************************************ *
function Htmlmake(HtmlFolder,HtmlFilename,HtmlContent)
On Error Resume Next
dim filepath,fso,fout
filepath = HtmlFolder&"/"&HtmlFilename
Set fso = Server.CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(HtmlFolder) Then
Else
CreateMultiFolder(HtmlFolder)
&, ;nbs, p; End If
Set fout = fso.Createtextfile(server.mappath(filepath),true)
fout.writeline HtmlContent
fout.close
set fso=nothing
Set fso = Server.CreateObject("Scripting.FileSystemObject")
If fso.fileexists(Server.MapPath(filepath)) Then
Response.Write "File<font color=red>"&HtmlFilename&"</font> has been generated!<br>"
Else
'Response.Write Server.MapPath(filepath)
Response.Write "File<font color=red>"&HtmlFilename&"</font> was not generated!<br>"
End If
Set fso = nothing
End function
'************************************************ *
'Function name: Htmldel
'Function: Use FSO to delete files
'Parameter: HtmlFolder ---- path
' HtmlFilename ---- file name
'************************************************ *
Sub Htmldel(HtmlFolder,HtmlFilename)
dim filepath,fso
filepath = HtmlFolder&"/"&HtmlFilename
Set fso = CreateObject("Scripting.FileSystemObject")
fso.DeleteFile(Server.mappath(filepath))
Set fso = nothing
Set fso = Server.CreateObject("Scripting.FileSystemObject")
If fso.fileexists(Server.MapPath(filepath)) Then
Response.Write "File<font color=red>"&HtmlFilename&"</font> is not deleted!<br>"
Else
'Response.Write Server.MapPath(filepath)
Response.Write "File<font color=red>"&HtmlFilename&"</font> has been deleted!<br>"
End If
Set fso = nothing
End Sub
'==================================================
'Process name: HTMLEncode
'Function: filter HTML format
'Parameter: fString ----Conversion content
'==================================================
function HTMLEncode(ByVal fString)
If IsNull(fString)=False or fString<>"" or fString<>"$False$" Then
fString = Replace(fString, ">", ">")
fString = Replace(fString, "<", "<")
fString = Replace(fString, Chr(32), " ")
fString = Replace(fString, Chr(9), " ")
fString = Replace(fString, Chr(34), """)
fString = Replace(fString, Chr(39), "'")
fString = Replace(fString, Chr(13), "")
fString = Replace(fString, " ", " ")
fString = Replace(fString, CHR(10) & CHR(10), "</P><P>")
fString = Replace(fString, Chr(10), "<br /> ")
HTMLEncode = fString
else
HTMLEncode = "$False$"
end if
end function
'==================================================
'Process name: unHTMLEncode
'Function: restore HTML format
'Parameter: fString ----Conversion content
'==================================================
function unHTMLEncode(ByVal fString)
If IsNull(fString)=False or fString<>"" or fString<>"$False$" Then
fString = Replace(fString, ">", ">")
fString = Replace(fString, "<", "<")
fString = Replace(fString, " ", Chr(32))
fString = Replace(fString, """, Chr(34))
fString = Replace(fString, "'", Chr(39))
fString = Replace(fString, "", Chr(13))
fString = Replace(fString, " ", " ")
fString = Replace(fString, "</P><P>" , CHR(10) & CHR(10))
fString = Replace(fString, "<br> ", Chr(10))
unHTMLEncode = fString
else
unHTMLEncode = "$False$"
end if
end function
function unhtmllist(content)
unhtmllist=content
if content <> "" then
unhtmllist=replace(unhtmllist,"'","";")
unhtmllist=replace(unhtmllist,chr(10),"")
unHtmllist=replace(unHtmllist,chr(13),"<br>")
end if
end function
function unhtmllists(content)
unhtmllists=content
if content <> "" then
unhtmllists=replace(unhtmllists,"""","")
unhtmllists=replace(unhtmllists,"'","")
unhtmllists=replace(unhtmllists,chr(10),"")
unHtmllists=replace(unHtmllists,chr(13),"<br>")
end if
end function
function htmllists(content)
htmllists=content
if content <> "" then
htmllists=replace(htmllists,"''","""")
htmllists=replace(htmllists,"","'")
htmllists=replace(htmllists,"<br>",chr(13)&chr(10))
end if
end function
function uhtmllists(content)
uhtmllists=content
if content <> "" then
uhtlists=replace(uhtlists,"""","''")
uhtlists=replace(uhtlists,"'","";")
uhtlists=replace(uhtlists,chr(10),"")
uHtmllists=replace(uHtmllists,chr(13),"<br>")
end if
end function
'==================================================
'Process: Sleep
'Function: The program stops here for a few seconds
'Parameters: iSeconds Number of seconds to pause
'==================================================
Sub Sleep(iSeconds)
response.Write "<font color=blue>Start pausing for "&iSeconds&" seconds</font><br>"
Dim t:t=Timer()
While(Timer()<t+iSeconds)
'Do Nothing
Wend
response.Write "<font color=blue>Pause"&iSeconds&" seconds end</font><br>"
End Sub
'================================================== =
'Function name: MyArray
'Function: extract tags to separate
'Parameter: ConStr ------Extract the original characters of the address
'================================================== =
Function MyArray(ByvalConStr)
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "({).+?(})"
Set Matches =objRegExp.Execute(ConStr)
For Each Match in Matches
TempStr=TempStr & "" & Match.Value
Next
Set Matches=nothing
TempStr=Right(TempStr,Len(TempStr)-1)
objRegExp.Pattern="{"
TempStr=objRegExp.Replace(TempStr,"")
objRegExp.Pattern="}"
TempStr=objRegExp.Replace(TempStr,"")
Set objRegExp=nothing
Set Matches=nothing
TempStr=Replace(TempStr,"$","")
If TempStr="" then
MyArray="Nothing to extract in code"
Else
MyArray=TempStr
End if
End Function
'================================================== =
'Function name: randm
'Function: Generate 6-digit random number
'================================================== =
Function randm
randomize
randm=Int((900000*rnd)+100000)
End Function
%>