'================================================== 
'函數(shù)名：GetHttpPage 
'作 用：獲取網(wǎng)頁源碼 
'參 數(shù)：HttpUrl ------網(wǎng)頁地址 
'================================================== 
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 

'================================================== 
'函數(shù)名：BytesToBstr 
'作 用：將獲取的源碼轉(zhuǎn)換為中文 
'參 數(shù)：Body ------要轉(zhuǎn)換的變量 
'參 數(shù)：Cset ------要轉(zhuǎn)換的類型 
'================================================== 
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 

'================================================== 
'函數(shù)名：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 

'================================================== 
'函數(shù)名：UrlEncoding 
'作 用：轉(zhuǎn)換編碼 
'================================================== 
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 

'================================================== 
'函數(shù)名：GetBody 
'作 用：截取字符串 
'參 數(shù)：ConStr ------將要截取的字符串 
'參 數(shù)：StartStr ------開始字符串 
'參 數(shù)：OverStr ------結(jié)束字符串 
'參 數(shù)：IncluL ------是否包含StartStr 
'參 數(shù)：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 



'================================================== 
'函數(shù)名：GetArray 
'作 用：提取鏈接地址，以$Array$分隔 
'參 數(shù)：ConStr ------提取地址的原字符 
'參 數(shù)：StartStr ------開始字符串 
'參 數(shù)：OverStr ------結(jié)束字符串 
'參 數(shù)：IncluL ------是否包含StartStr 
'參 數(shù)：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 


'================================================== 
'函數(shù)名：DefiniteUrl 
'作 用：將相對地址轉(zhuǎn)換為絕對地址 
'參 數(shù)：PrimitiveUrl ------要轉(zhuǎn)換的相對地址 
'參 數(shù)：ConsultUrl ------當(dāng)前網(wǎng)頁地址 
'================================================== 
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 

'================================================== 
'函數(shù)名：ReplaceSaveRemoteFile 
'作 用：替換、保存遠程圖片 
'參 數(shù)：ConStr ------ 要替換的字符串 
'參 數(shù)：SaveTf ------ 是否保存文件，F(xiàn)alse不保存，True保存 
'參 數(shù): TistUrl------ 當(dāng)前網(wǎng)頁地址 
'================================================== 
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&"目錄創(chuàng)建失敗" 
SaveTf=False 
End If 
End If 
End If 

'去掉重復(fù)圖片開始 
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$") 
'去掉重復(fù)圖片結(jié)束 

response.Write "<br>發(fā)現(xiàn)圖片:<br>"&Replace(TempStr,"$Array$","<br>") 

'轉(zhuǎn)換相對圖片地址開始 
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="" 
'轉(zhuǎn)換相對圖片地址結(jié)束 

'圖片替換/保存 
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 

'================================================== 
'函數(shù)名：ReplaceSwfFile 
'作 用：解析動畫路徑 
'參 數(shù)：ConStr ------ 要替換的字符串 
'參 數(shù): TistUrl------ 當(dāng)前網(wǎng)頁地址 
'================================================== 
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 

'去掉重復(fù)文件開始 
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$") 
'去掉重復(fù)文件結(jié)束 

'轉(zhuǎn)換相對地址開始 
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="" 
'轉(zhuǎn)換相對地址結(jié)束 

'替換 
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 
'作 用：保存遠程的文件到本地 
'參 數(shù)：LocalFileName ------ 本地文件名 
'參 數(shù)：RemoteFileUrl ------ 遠程文件URL 
'參 數(shù)：Referer ------ 遠程調(diào)用文件（對付防采集的，用內(nèi)容頁地址，沒有防的留空） 
'================================================== 
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 

'================================================== 
'函數(shù)名：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 

'************************************************* 
'函數(shù)名：gotTopic 
'作 用：截字符串，漢字一個算兩個字符，英文算一個字符 
'參 數(shù)：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 

'*********************************************** 
'函數(shù)名：JoinChar 
'作 用：向地址中加入 ? 或 & 
'參 數(shù)：strUrl ----網(wǎng)址 
'返回值：加了 ? 或 & 的網(wǎng)址 
'*********************************************** 
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 


'************************************************** 
'函數(shù)名：CreateKeyWord 
'作 用：由給定的字符串生成關(guān)鍵字 
'參 數(shù)：Constr---要生成關(guān)鍵字的原字符串 
'返回值：生成的關(guān)鍵字 
'************************************************** 
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 

'================================================== 
'函數(shù)名：CheckUrl 
'作 用：檢查Url 
'參 數(shù)：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 

'================================================== 
'函數(shù)名：ScriptHtml 
'作 用：過濾html標(biāo)記 
'參 數(shù)：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 

'================================================== 
'函數(shù)名：RemoveHTML 
'作 用：完全去除html標(biāo)記 
'參 數(shù)：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 

'================================================== 
'函數(shù)名：CheckDir 
'作 用：檢查文件夾是否存在 
'參 數(shù)：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 

'================================================== 
'函數(shù)名：MakeNewsDir 
'作 用：創(chuàng)建文件夾 
'參 數(shù)：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 

'================================================== 
'函數(shù)名：DelDir 
'作 用：創(chuàng)建文件夾 
'參 數(shù)：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 

'************************************************** 
'函數(shù)名：IsObjInstalled 
'作 用：檢查組件是否已經(jīng)安裝 
'參 數(shù)：strClassString ----組件名 
'返回值：True ----已經(jīng)安裝 
' 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 

'************************************************** 
'函數(shù)名：strLength 
'作 用：求字符串長度。漢字算兩個字符，英文算一個字符。 
'參 數(shù)：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 


'**************************************************** 
'函數(shù)名：CreateMultiFolder 
'作 用：創(chuàng)建多級目錄，可以創(chuàng)建不存在的根目錄 
'參 數(shù)：要創(chuàng)建的目錄名稱，可以是多級 
'返回邏輯值：True成功，F(xiàn)alse失敗 
'創(chuàng)建目錄的根目錄從當(dāng)前目錄開始 
'**************************************************** 
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 

'************************************************** 
'函數(shù)名：FSOFileRead 
'作 用：使用FSO讀取文件內(nèi)容的函數(shù) 
'參 數(shù)：filename ----文件名稱 
'返回值：文件內(nèi)容 
'************************************************** 
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 

'************************************************** 
'函數(shù)名：FSOlinedit 
'作 用：使用FSO讀取文件某一行的函數(shù) 
'參 數(shù)：filename ----文件名稱 
' lineNum ----行數(shù) 
'返回值：文件該行內(nèi)容 
'************************************************** 
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 

'************************************************** 
'函數(shù)名：FSOlinewrite 
'作 用：使用FSO寫文件某一行的函數(shù) 
'參 數(shù)：filename ----文件名稱 
' lineNum ----行數(shù) 
' Linecontent ----內(nèi)容 
'返回值：無 
'************************************************** 
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 

'************************************************** 
'函數(shù)名：Htmlmake 
'作 用：使用FSO創(chuàng)建文件 
'參 數(shù)：HtmlFolder ----路徑 
' HtmlFilename ----文件名 
' HtmlContent ----內(nèi)容 
'************************************************** 
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 

'************************************************** 
'函數(shù)名：Htmldel 
'作 用：使用FSO刪除文件 
'參 數(shù)：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格式 
'參 數(shù)：fString ----轉(zhuǎn)換內(nèi)容 
'================================================= 
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格式 
'參 數(shù)：fString ----轉(zhuǎn)換內(nèi)容 
'================================================= 
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 
'功能： 程序在此晢停幾秒 
'參數(shù)： iSeconds 要暫停的秒數(shù) 
'================================================= 
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&" 秒結(jié)束</font><br>" 
End Sub 

'================================================== 
'函數(shù)名：MyArray 
'作 用：提取標(biāo)簽，以分隔 
'參 數(shù)：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 

'================================================== 
'函數(shù)名：randm 
'作 用：產(chǎn)生6位隨機數(shù) 
'================================================== 
Function randm 
randomize 
randm=Int((900000*rnd)+100000) 
End Function 
%>