本文提供了一套完整的ASP採集功能函數,包含提取地址的原字符,保存遠端的文件到本地模擬登錄,獲取網頁源碼等功能函數複製代碼代碼如下:
'================================================== =
'函數名稱：GetHttpPage
'作用：取得網頁原始碼
'參數：HttpUrl ------網頁位址
'================================================== =
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
'================================================== =
'函數名稱：BytesToBstr
'作用：將取得的原始碼轉換為中文
'參數：Body ------要轉換的變數
'參數：Cset ------要轉換的類型
'================================================== =
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
'================================================== =
'函數名稱：PostHttpPage
'作用：登入
'================================================== =
Function PostHttpPage(RefererUrl,PostUrl,PostData)
Dim xmlHttp
Dim RetStr
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
'================================================== =
'函式名稱：UrlEncoding
'作用：轉換編碼
'================================================== =
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
'================================================== =
'函數名稱：GetBody
'作用：截取字串
'參數：ConStr ------將要截取的字串
'參數：StartStr ------開始字串
'參數：OverStr ------結束字串
'參數：IncluL ------是否包含StartStr
'參數：IncluR ------是否包含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
Dim ConStrTemp
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 IncluR=True Then
Over=Over+LenB(OverStr)
End If
End If
GetBody=MidB(ConStr,Start,Over-Start)
End Function
'================================================== =
'函數名稱：GetArray
'作用：提取連結地址，以$Array$分隔
'參數：ConStr ------提取位址的原字符
'參數：StartStr ------開始字串
'參數：OverStr ------結束字串
'參數：IncluL ------是否包含StartStr
'參數：IncluR ------是否包含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 IncluR=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
'================================================== =
'函數名稱：DefiniteUrl
'作用：將相對地址轉換為絕對地址
'參數：PrimitiveUrl ------要轉換的相對位址
'參數：ConsultUrl ------目前網頁位址
'================================================== =
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
'================================================== =
'函數名稱：ReplaceSaveRemoteFile
'作用：替換、保存遠端圖片
'參數：ConStr ------ 要替換的字串
'參數：SaveTf ------ 是否儲存文件，False不儲存，True儲存
'參數: TistUrl------ 目前網頁位址
'================================================== =
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= 或 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&目錄建立失敗
SaveTf=False
End If
End If
End If
'去掉重複圖片開始
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$)
'去掉重複圖片結束
response.Write <br>發現圖片:<br>&Replace(TempStr,$Array$,<br>)
'轉換相對圖片地址開始
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=
'轉換相對圖片地址結束
'圖片替換/保存
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'儲存圖片
ArrSaveFileName = Split(RemoteFileurl,.)
strFileType=Lcase(ArrSaveFileName(Ubound(ArrSaveFileName)))'檔案類型
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>儲存到本機位址:&InstallPath & strChannelDir & strFileName
If SaveRemoteFile(InstallPath & strChannelDir & strFileName,RemoteFileUrl,RemoteFileUrl)=True Then
response.Write <font color=blue>成功</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'不儲存圖片
Re.Pattern =TempArray(Tempi)
ConStr=Re.Replace(ConStr,RemoteFileUrl)
End If
'********************************
Next
Set Re=nothing
ReplaceSaveRemoteFile=ConStr
End function
'================================================== =
'函數名：ReplaceSwfFile
'作用：解析動畫路徑
'參數：ConStr ------ 要替換的字串
'參數: TistUrl------ 目前網頁位址
'================================================== =
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= 或 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
'去掉重複檔案開始
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$)
'去掉重複檔案結束
'轉換相對地址開始
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=
'轉換相對位址結束
'替換
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
'================================================== =
'過程名稱：SaveRemoteFile
'作用：保存遠端的檔案到本機
'參數：LocalFileName ------ 本地檔名
'參數：RemoteFileUrl ------ 遠端檔案URL
'參數：Referer ------ 遠端呼叫檔案（對付防採集的，用內容頁位址，沒有防的留空）
'================================================== =
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
'================================================== =
'函數名稱：GetPaing
'作用：取得分頁
'================================================== =
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 IncluR=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
'*************************************************
'函數名稱：gotTopic
'作用：截字串，漢字一個算兩個字符，英文算一個字符
'參數：str ----原字串
' strlen ----截取長度
'傳回值：截取後的字串
'*************************************************
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
'***********************************************
'函數名稱：JoinChar
'作用：向地址中加入? 或&
'參數：strUrl ----網址
'傳回值：加了? 或& 的網址
'***********************************************
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
'************************************************* *
'函數名稱：CreateKeyWord
'作用：由給定的字串產生關鍵字
'參數：Constr---要產生關鍵字的原始字串
'傳回值：產生的關鍵字
'************************************************* *
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
'================================================== =
'函數名稱：CheckUrl
'作用：檢查Url
'參數：strUrl ------ 要檢查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
'================================================== =
'函數名稱：ScriptHtml
'作用：過濾html標記
'參數：ConStr ------ 要過濾的字串
'================================================== =
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
'================================================== =
'函數名稱：RemoveHTML
'作用：完全去除html標記
'參數：strHTML ------ 要過濾的字串
'================================================== =
Function RemoveHTML(strHTML)
Dim objRegExp, Match, Matches
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
'取閉合的<>
objRegExp.Pattern = <.+?>
'進行匹配
Set Matches = objRegExp.Execute(strHTML)
' 遍歷匹配集合，並替換掉匹配的項目
For Each Match in Matches
strHtml=Replace(strHTML,Match.Value,)
Next
RemoveHTML=strHTML
Set objRegExp = Nothing
End Function
'================================================== =
'函數名稱：CheckDir
'作用：檢查資料夾是否存在
'參數：FolderPath ------ 資料夾路徑
'================================================== =
Function CheckDir(byval FolderPath)
dim fso
Set fso = Server.CreateObject(Scripting.FileSystemObject)
If fso.FolderExists(Server.MapPath(folderpath)) then
'存在
CheckDir = True
Else
'不存在
CheckDir = False
End if
Set fso = nothing
End Function
'================================================== =
'函數名稱：MakeNewsDir
'作用：建立資料夾
'參數：foldername ------ 資料夾名
'================================================== =
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
'================================================== =
'函數名稱：DelDir
'作用：建立資料夾
'參數：foldername ------ 資料夾名
'================================================== =
Function DelDir(byval foldername)
dim fso
Set fso = Server.CreateObject(Scri & pti & ng.Fil & eSyst & emOb & ject)
If fso.FolderExists(Server.MapPath(foldername)) Then '判斷資料夾是否存在
fso.DeleteFolder (Server.MapPath(foldername)) '刪除資料夾
End If
Set fso = nothing
End Function
'************************************************* *
'函式名稱：IsObjInstalled
'作用：檢查組件是否已安裝
'參數：strClassString ----元件名
'傳回值：True ----已經安裝
' False ----沒有安裝
'************************************************* *
Function IsObjInstalled(strClassString)
IsObjInstalled = False
Err = 0
Dim xTestObj
Set xTestObj = Server.CreateObject(strClassString)
If 0 = Err Then IsObjInstalled = True
Set xTestObj = Nothing
Err = 0
End Function
'************************************************* *
'函數名稱：strLength
'作用：求字串長度。漢字算兩個字符，英文算一個字符。
'參數：str ----要求長度的字串
'傳回值：字串長度
'************************************************* *
function strLength(str)
ON ERROR RESUME NEXT
dim WINNT_CHINESE
WINNT_CHINESE = (len(中國)=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
'************************************************* ***
'函數名稱：CreateMultiFolder
'作用：建立多層目錄，可以建立不存在的根目錄
'參數：要建立的目錄名稱，可以是多級
'傳回邏輯值：True成功，False失敗
'建立目錄的根目錄從目前目錄開始
'************************************************* ***
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 =
為 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
'************************************************* *
'函數名稱：FSOFileRead
'作用：使用FSO讀取檔案內容的函數
'參數：filename ----檔案名稱
'傳回值：文件內容
'************************************************* *
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
'************************************************* *
'函數名稱：FSOlinedit
'作用：使用FSO讀取檔案某一行的函數
'參數：filename ----檔案名稱
' lineNum ----行數
'傳回值：文件該行內容
'************************************************* *
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
'************************************************* *
'函數名稱：FSOlinewrite
'作用：使用FSO寫入檔案某一行的函數
'參數：filename ----檔案名稱
' lineNum ----行數
' Linecontent ----內容
'傳回值：無
'************************************************* *
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.write tempcnt
end if
f.close
set f = nothing
end function
'************************************************* *
'函數名：Htmlmake
'作用：使用FSO建立文件
'參數：HtmlFolder ----路徑
' HtmlFilename ----檔名
' HtmlContent ----內容
'************************************************* *
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 檔案<font color=red>&HtmlFilename&</font>已產生!<br>
Else
'Response.Write Server.MapPath(filepath)
Response.Write 檔案<font color=red>&HtmlFilename&</font>未產生!<br>
End If
Set fso = nothing
End function
'************************************************* *
'函數名稱：Htmldel
'作用：使用FSO刪除文件
'參數：HtmlFolder ----路徑
' HtmlFilename ----檔名
'************************************************* *
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 檔案<font color=red>&HtmlFilename&</font>未刪除!<br>
Else
'Response.Write Server.MapPath(filepath)
Response.Write 檔案<font color=red>&HtmlFilename&</font>已刪除!<br>
End If
Set fso = nothing
End Sub
'==================================================
'過程名：HTMLEncode
'作用：過濾HTML格式
'參數：fString ----轉換內容
'==================================================
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
'==================================================
'過程名：unHTMLEncode
'作用：還原HTML格式
'參數：fString ----轉換內容
'==================================================
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
uhtmllists=replace(uhtmllists,,'')
uhtmllists=replace(uhtmllists,',;)
uhtmllists=replace(uhtmllists,chr(10),)
uHtmllists=replace(uHtmllists,chr(13),<br>)
end if
end function
'==================================================
'過程： Sleep
'功能： 程式在此晢停幾秒
'參數： iSeconds 要暫停的秒數
'==================================================
Sub Sleep(iSeconds)
response.Write <font color=blue>開始暫停&iSeconds& 秒</font><br>
Dim t:t=Timer()
While(Timer()<t+iSeconds)
'Do Nothing
Wend
response.Write <font color=blue>暫停&iSeconds& 秒結束</font><br>
End Sub
'================================================== =
'函數名稱：MyArray
'作用：提取標籤，以分隔
'參數：ConStr ------提取位址的原字符
'================================================== =
Function MyArray(Byval ConStr)
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=在程式碼中沒有可提取的東西
Else
MyArray=TempStr
End if
End Function
'================================================== =
'函數名稱：randm
'作用：產生6位數隨機數
'================================================== =
Function randm
randomize
randm=Int((900000*rnd)+100000)
End Function
%>