您的位置:首页 > 其它

一个带采集远程文章内容,保存图片,生成文件等完整的采集功能

2009-06-29 00:00 811 查看
'================================================== 
'函数名: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="" 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&"目录创建失败" 
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="" 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 

'去掉重复文件开始 
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 = "" 
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 

'************************************************** 
'函数名: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 
%>
内容来自用户分享和网络整理,不保证内容的准确性,如有侵权内容,可联系管理员处理 点击这里给我发消息
标签: 
相关文章推荐