登 录
asp+XMLHTTP组件做采集常用函数
'==================================================<br /> '函数名：GetHttpPage<br /> '作 用：获取网页源码<br /> '参 数：HttpUrl ------网页地址<br /> '==================================================<br /> Function GetHttpPage(HttpUrl)<br /> If IsNull(HttpUrl)=True Or Len(HttpUrl)<18 Or HttpUrl="$False$" Then<br /> GetHttpPage="$False$"<br /> Exit Function<br /> End If<br /> Dim Http<br /> Set Http=server.createobject("MSXML2.XMLHTTP")<br /> Http.open "GET",HttpUrl,False<br /> Http.Send()<br /> If Http.Readystate<>4 then<br /> Set Http=Nothing<br /> GetHttpPage="$False$"<br /> Exit function<br /> End if<br /> GetHTTPPage=bytesToBSTR(Http.responseBody,"GB2312")<br /> Set Http=Nothing<br /> If Err.number<>0 then<br /> Err.Clear<br /> End If<br /> End Function</p> <p>'==================================================<br /> '函数名：BytesToBstr<br /> '作 用：将获取的源码转换为中文<br /> '参 数：Body ------要转换的变量<br /> '参 数：Cset ------要转换的类型<br /> '==================================================<br /> Function BytesToBstr(Body,Cset)<br /> Dim Objstream<br /> Set Objstream = Server.CreateObject("adodb.stream")<br /> objstream.Type = 1<br /> objstream.Mode =3<br /> objstream.Open<br /> objstream.Write body<br /> objstream.Position = 0<br /> objstream.Type = 2<br /> objstream.Charset = Cset<br /> BytesToBstr = objstream.ReadText<br /> objstream.Close<br /> set objstream = nothing<br /> End Function</p> <p>'==================================================<br /> '函数名：PostHttpPage<br /> '作 用：登录<br /> '==================================================<br /> Function PostHttpPage(RefererUrl,PostUrl,PostData)<br /> Dim xmlHttp<br /> Dim RetStr<br /> Set xmlHttp = CreateObject("Msxml2.XMLHTTP")<br /> xmlHttp.Open "POST", PostUrl, False<br /> XmlHTTP.setRequestHeader "Content-Length",Len(PostData)<br /> xmlHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"<br /> xmlHttp.setRequestHeader "Referer", RefererUrl<br /> xmlHttp.Send PostData<br /> If Err.Number <> 0 Then<br /> Set xmlHttp=Nothing<br /> PostHttpPage = "$False$"<br /> Exit Function<br /> End If<br /> PostHttpPage=bytesToBSTR(xmlHttp.responseBody,"GB2312")<br /> Set xmlHttp = nothing<br /> End Function </p> <p>'==================================================<br /> '函数名：UrlEncoding<br /> '作 用：转换编码<br /> '==================================================<br /> Function UrlEncoding(DataStr)<br /> Dim StrReturn,Si,ThisChr,InnerCode,Hight8,Low8<br /> StrReturn = ""<br /> For Si = 1 To Len(DataStr)<br /> ThisChr = Mid(DataStr,Si,1)<br /> If Abs(Asc(ThisChr)) < &HFF Then<br /> StrReturn = StrReturn & ThisChr<br /> Else<br /> InnerCode = Asc(ThisChr)<br /> If InnerCode < 0 Then<br /> InnerCode = InnerCode + &H10000<br /> End If<br /> Hight8 = (InnerCode And &HFF00)/ &HFF<br /> Low8 = InnerCode And &HFF<br /> StrReturn = StrReturn & "%" & Hex(Hight8) & "%" & Hex(Low8)<br /> End If<br /> Next<br /> UrlEncoding = StrReturn<br /> End Function</p> <p>'==================================================<br /> '函数名：GetBody<br /> '作 用：截取字符串<br /> '参 数：ConStr ------将要截取的字符串<br /> '参 数：StartStr ------开始字符串<br /> '参 数：OverStr ------结束字符串<br /> '参 数：IncluL ------是否包含StartStr<br /> '参 数：IncluR ------是否包含OverStr<br /> '==================================================<br /> Function GetBody(ConStr,StartStr,OverStr,IncluL,IncluR)<br /> If ConStr="$False$" or ConStr="" or IsNull(ConStr)=True Or StartStr="" or IsNull(StartStr)=True Or OverStr="" or IsNull(OverStr)=True Then<br /> GetBody="$False$"<br /> Exit Function<br /> End If<br /> Dim ConStrTemp<br /> Dim Start,Over<br /> ConStrTemp=Lcase(ConStr)<br /> StartStr=Lcase(StartStr)<br /> OverStr=Lcase(OverStr)<br /> Start = InStrB(1, ConStrTemp, StartStr, vbBinaryCompare)<br /> If Start<=0 then<br /> GetBody="$False$"<br /> Exit Function<br /> Else<br /> If IncluL=False Then<br /> Start=Start+LenB(StartStr)<br /> End If<br /> End If<br /> Over=InStrB(Start,ConStrTemp,OverStr,vbBinaryCompare)<br /> If Over<=0 Or Over<=Start then<br /> GetBody="$False$"<br /> Exit Function<br /> Else<br /> If IncluR=True Then<br /> Over=Over+LenB(OverStr)<br /> End If<br /> End If<br /> GetBody=MidB(ConStr,Start,Over-Start)<br /> End Function</p> <p>'==================================================<br /> '函数名：GetArray<br /> '作 用：提取链接地址，以$Array$分隔<br /> '参 数：ConStr ------提取地址的原字符<br /> '参 数：StartStr ------开始字符串<br /> '参 数：OverStr ------结束字符串<br /> '参 数：IncluL ------是否包含StartStr<br /> '参 数：IncluR ------是否包含OverStr<br /> '==================================================<br /> Function GetArray(Byval ConStr,StartStr,OverStr,IncluL,IncluR)<br /> If ConStr="$False$" or ConStr="" Or IsNull(ConStr)=True or StartStr="" Or OverStr="" or IsNull(StartStr)=True Or IsNull(OverStr)=True Then<br /> GetArray="$False$"<br /> Exit Function<br /> End If<br /> Dim TempStr,TempStr2,objRegExp,Matches,Match<br /> TempStr=""<br /> Set objRegExp = New Regexp<br /> objRegExp.IgnoreCase = True<br /> objRegExp.Global = True<br /> objRegExp.Pattern = "("&StartStr&").+?("&OverStr&")"<br /> Set Matches =objRegExp.Execute(ConStr)<br /> For Each Match in Matches<br /> TempStr=TempStr & "$Array$" & Match.Value<br /> Next<br /> Set Matches=nothing</p> <p>If TempStr="" Then<br /> GetArray="$False$"<br /> Exit Function<br /> End If<br /> TempStr=Right(TempStr,Len(TempStr)-7)<br /> If IncluL=False then<br /> objRegExp.Pattern =StartStr<br /> TempStr=objRegExp.Replace(TempStr,"")<br /> End if<br /> If IncluR=False then<br /> objRegExp.Pattern =OverStr<br /> TempStr=objRegExp.Replace(TempStr,"")<br /> End if<br /> Set objRegExp=nothing</p> <p>TempStr=Replace(TempStr,"""","")<br /> TempStr=Replace(TempStr,"'","")<br /> TempStr=Replace(TempStr," ","")<br /> If TempStr="" then<br /> GetArray="$False$"<br /> Else<br /> GetArray=TempStr<br /> End if<br /> End Function</p> <p>'==================================================<br /> '函数名：DefiniteUrl<br /> '作 用：将相对地址转换为绝对地址<br /> '参 数：PrimitiveUrl ------要转换的相对地址<br /> '参 数：ConsultUrl ------当前网页地址<br /> '==================================================<br /> Function DefiniteUrl(Byval PrimitiveUrl,Byval ConsultUrl)<br /> Dim ConTemp,PriTemp,Pi,Ci,PriArray,ConArray<br /> If PrimitiveUrl="" or ConsultUrl="" or PrimitiveUrl="$False$" or ConsultUrl="$False$" Then<br /> DefiniteUrl="$False$"<br /> Exit Function<br /> End If<br /> If Left(Lcase(ConsultUrl),7)<>"http://" Then<br /> ConsultUrl= "http://" & ConsultUrl<br /> End If<br /> ConsultUrl=Replace(ConsultUrl,"/","/")<br /> ConsultUrl=Replace(ConsultUrl,"://","://")<br /> PrimitiveUrl=Replace(PrimitiveUrl,"/","/")</p> <p>If Right(ConsultUrl,1)<>"/" Then<br /> If Instr(ConsultUrl,"/")>0 Then<br /> If Instr(Right(ConsultUrl,Len(ConsultUrl)-InstrRev(ConsultUrl,"/")),".")>0 then<br /> Else<br /> ConsultUrl=ConsultUrl & "/"<br /> End If<br /> Else<br /> ConsultUrl=ConsultUrl & "/"<br /> End If<br /> End If<br /> ConArray=Split(ConsultUrl,"/")</p> <p>If Left(LCase(PrimitiveUrl),7) = "http://" then<br /> DefiniteUrl=Replace(PrimitiveUrl,"://","://")<br /> ElseIf Left(PrimitiveUrl,1) = "/" Then<br /> DefiniteUrl=ConArray(0) & PrimitiveUrl<br /> ElseIf Left(PrimitiveUrl,2)="./" Then<br /> PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-2)<br /> If Right(ConsultUrl,1)="/" Then<br /> DefiniteUrl=ConsultUrl & PrimitiveUrl<br /> Else<br /> DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl<br /> End If<br /> ElseIf Left(PrimitiveUrl,3)="../" then<br /> Do While Left(PrimitiveUrl,3)="../"<br /> PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-3)<br /> Pi=Pi+1<br /> Loop<br /> For Ci=0 to (Ubound(ConArray)-1-Pi)<br /> If DefiniteUrl<>"" Then<br /> DefiniteUrl=DefiniteUrl & "/" & ConArray(Ci)<br /> Else<br /> DefiniteUrl=ConArray(Ci)<br /> End If<br /> Next<br /> DefiniteUrl=DefiniteUrl & "/" & PrimitiveUrl<br /> Else<br /> If Instr(PrimitiveUrl,"/")>0 Then<br /> PriArray=Split(PrimitiveUrl,"/")<br /> If Instr(PriArray(0),".")>0 Then<br /> If Right(PrimitiveUrl,1)="/" Then<br /> DefiniteUrl="http://" & PrimitiveUrl<br /> Else<br /> If Instr(PriArray(Ubound(PriArray)-1),".")>0 Then<br /> DefiniteUrl="http://" & PrimitiveUrl<br /> Else<br /> DefiniteUrl="http://" & PrimitiveUrl & "/"<br /> End If<br /> End If<br /> Else<br /> If Right(ConsultUrl,1)="/" Then<br /> DefiniteUrl=ConsultUrl & PrimitiveUrl<br /> Else<br /> DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl<br /> End If<br /> End If<br /> Else<br /> If Instr(PrimitiveUrl,".")>0 Then<br /> If Right(ConsultUrl,1)="/" Then<br /> 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<br /> DefiniteUrl="http://" & PrimitiveUrl & "/"<br /> Else<br /> DefiniteUrl=ConsultUrl & PrimitiveUrl<br /> End If<br /> Else<br /> 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<br /> DefiniteUrl="http://" & PrimitiveUrl & "/"<br /> Else<br /> DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl<br /> End If<br /> End If<br /> Else<br /> If Right(ConsultUrl,1)="/" Then<br /> DefiniteUrl=ConsultUrl & PrimitiveUrl & "/"<br /> Else<br /> DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl & "/"<br /> End If<br /> End If<br /> End If<br /> End If<br /> If Left(DefiniteUrl,1)="/" then<br /> DefiniteUrl=Right(DefiniteUrl,Len(DefiniteUrl)-1)<br /> End if<br /> If DefiniteUrl<>"" Then<br /> DefiniteUrl=Replace(DefiniteUrl,"//","/")<br /> DefiniteUrl=Replace(DefiniteUrl,"://","://")<br /> Else<br /> DefiniteUrl="$False$"<br /> End If<br /> End Function</p> <p>'==================================================<br /> '函数名：ReplaceSaveRemoteFile<br /> '作 用：替换、保存远程图片<br /> '参 数：ConStr ------ 要替换的字符串<br /> '参 数：SaveTf ------ 是否保存文件，False不保存，True保存<br /> '参 数: TistUrl------ 当前网页地址<br /> '==================================================<br /> Function ReplaceSaveRemoteFile(ConStr,strInstallDir,strChannelDir,SaveTf,TistUrl)<br /> If ConStr="$False$" or ConStr="" or strInstallDir="" or strChannelDir="" Then<br /> ReplaceSaveRemoteFile=ConStr<br /> Exit Function<br /> End If<br /> Dim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2<br /> Dim Start1,Start2</p> <p>Set Re = New Regexp<br /> Re.IgnoreCase = True<br /> Re.Global = True<br /> Re.Pattern ="<img.+?[^/>]>"<br /> Set Matches =Re.Execute(ConStr)<br /> For Each Match in Matches<br /> If TempStr<>"" then<br /> TempStr=TempStr & "$Array$" & Match.Value<br /> Else<br /> TempStr=Match.Value<br /> End if<br /> Next<br /> If TempStr<>"" Then<br /> TempArray=Split(TempStr,"$Array$")<br /> TempStr=""<br /> For Tempi=0 To Ubound(TempArray)<br /> Re.Pattern ="src/s*=/s*.+?/.(gif|jpg|bmp|jpeg|psd|png|svg|dxf|wmf|tiff)"<br /> Set Matches =Re.Execute(TempArray(Tempi))<br /> For Each Match in Matches<br /> If TempStr<>"" then<br /> TempStr=TempStr & "$Array$" & Match.Value<br /> Else<br /> TempStr=Match.Value<br /> End if<br /> Next<br /> Next<br /> End if<br /> If TempStr<>"" Then<br /> Re.Pattern ="src/s*=/s*"<br /> TempStr=Re.Replace(TempStr,"")<br /> End If<br /> Set Matches=nothing<br /> Set Re=nothing<br /> If TempStr="" or IsNull(TempStr)=True Then<br /> ReplaceSaveRemoteFile=ConStr<br /> Exit function<br /> End if<br /> TempStr=Replace(TempStr,"""","")<br /> TempStr=Replace(TempStr,"'","")<br /> TempStr=Replace(TempStr," ","")</p> <p>Dim RemoteFileurl,SavePath,PathTemp,DtNow,strFileName,strFileType,ArrSaveFileName,RanNum,Arr_Path<br /> DtNow=Now()<br /> If SaveTf=True then<br /> SavePath=strInstallDir & strChannelDir & "/UploadFiles/" & year(DtNow) & right("0" & month(DtNow),2) & "/"<br /> Arr_Path=Split(SavePath,"/")<br /> PathTemp=""<br /> For Tempi=0 To Ubound(Arr_Path)<br /> If Tempi=0 Then<br /> PathTemp=Arr_Path(0) & "/"<br /> ElseIf Tempi=Ubound(Arr_Path) Then<br /> Exit For<br /> Else<br /> PathTemp=PathTemp & Arr_Path(Tempi) & "/"<br /> End If<br /> If CheckDir(PathTemp)=False Then<br /> If MakeNewsDir(PathTemp)=False Then<br /> SaveTf=False<br /> Exit For<br /> End If<br /> End If<br /> Next<br /> End If</p> <p>'去掉重复图片开始<br /> TempArray=Split(TempStr,"$Array$")<br /> TempStr=""<br /> For Tempi=0 To Ubound(TempArray)<br /> If Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Then<br /> TempStr=TempStr & "$Array$" & TempArray(Tempi)<br /> End If<br /> Next<br /> TempStr=Right(TempStr,Len(TempStr)-7)<br /> TempArray=Split(TempStr,"$Array$")<br /> '去掉重复图片结束</p> <p>'转换相对图片地址开始<br /> TempStr=""<br /> For Tempi=0 To Ubound(TempArray)<br /> TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)<br /> Next<br /> TempStr=Right(TempStr,Len(TempStr)-7)<br /> TempStr=Replace(TempStr,Chr(0),"")<br /> TempArray2=Split(TempStr,"$Array$")<br /> TempStr=""<br /> '转换相对图片地址结束</p> <p>'图片替换/保存<br /> Set Re = New Regexp<br /> Re.IgnoreCase = True<br /> Re.Global = True</p> <p>For Tempi=0 To Ubound(TempArray2)<br /> RemoteFileUrl=TempArray2(Tempi)<br /> If RemoteFileUrl<>"$False$" And SaveTf=True Then'保存图片<br /> ArrSaveFileName = Split(RemoteFileurl,".")<br /> strFileType=Lcase(ArrSaveFileName(Ubound(ArrSaveFileName)))'文件类型<br /> 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<br /> UploadFiles=""<br /> ReplaceSaveRemoteFile=ConStr<br /> Exit Function<br /> End If</p> <p>Randomize<br /> RanNum=Int(900*Rnd)+100<br /> 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<br /> Re.Pattern =TempArray(Tempi)<br /> If SaveRemoteFile(SavePath & strFileName,RemoteFileUrl)=True Then<br /> PathTemp=Replace(SavePath &strFileName,strInstallDir & strChannelDir & "/","[InstallDir_ChannelDir]")<br /> ConStr=Re.Replace(ConStr,PathTemp)<br /> Re.Pattern=strInstallDir & strChannelDir & "/"<br /> UploadFiles=UploadFiles & "|" & Re.Replace(SavePath &strFileName,"")<br /> Else<br /> PathTemp=RemoteFileUrl<br /> ConStr=Re.Replace(ConStr,PathTemp)<br /> 'UploadFiles=UploadFiles & "|" & RemoteFileUrl<br /> End If<br /> ElseIf RemoteFileurl<>"$False$" and SaveTf=False Then'不保存图片<br /> Re.Pattern =TempArray(Tempi)<br /> ConStr=Re.Replace(ConStr,RemoteFileUrl)<br /> UploadFiles=UploadFiles & "|" & RemoteFileUrl<br /> End If<br /> Next<br /> Set Re=nothing<br /> If UploadFiles<>"" Then<br /> UploadFiles=Right(UploadFiles,Len(UploadFiles)-1)<br /> End If<br /> ReplaceSaveRemoteFile=ConStr<br /> End function</p> <p>'==================================================<br /> '过程名：SaveRemoteFile<br /> '作 用：保存远程的文件到本地<br /> '参 数：LocalFileName ------ 本地文件名<br /> '参 数：RemoteFileUrl ------ 远程文件URL<br /> '==================================================<br /> Function SaveRemoteFile(LocalFileName,RemoteFileUrl)<br /> On error resume next<br /> SaveRemoteFile=True<br /> dim Ads,Retrieval,GetRemoteData<br /> Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")<br /> With Retrieval<br /> .Open "Get", RemoteFileUrl, False, "", ""<br /> .Send<br /> If .Readystate<>4 then<br /> SaveRemoteFile=False<br /> Exit Function<br /> End If<br /> GetRemoteData = .ResponseBody<br /> End With<br /> Set Retrieval = Nothing<br /> Set Ads = Server.CreateObject("Adodb.Stream")<br /> With Ads<br /> .Type = 1<br /> .Open<br /> .Write GetRemoteData<br /> .SaveToFile server.MapPath(LocalFileName),2<br /> .Cancel()<br /> .Close()<br /> End With<br /> Set Ads=nothing<br /> end Function</p> <p>'==================================================<br /> '函数名：FpHtmlEnCode<br /> '作 用：标题过滤<br /> '参 数：fString ------字符串<br /> '==================================================<br /> Function FpHtmlEnCode(fString)<br /> If IsNull(fString)=False or fString<>"" or fString<>"$False$" Then<br /> fString=nohtml(fString)<br /> fString=FilterJS(fString)<br /> fString = Replace(fString, CHR(9), "")<br /> fString = Replace(fString, CHR(34), "")<br /> fString = Replace(fString, CHR(39), "")<br /> fString = Replace(fString, CHR(13), "")<br /> fString = Replace(fString, CHR(10), " ")<br /> fString=Trim(fString)<br /> fString=dvhtmlencode(fString)<br /> FpHtmlEnCode=fString<br /> Else<br /> FpHtmlEnCode="$False$"<br /> End If<br /> End Function</p> <p>'==================================================<br /> '函数名：GetPaing<br /> '作 用：获取分页<br /> '==================================================<br /> Function GetPaing(Byval ConStr,StartStr,OverStr,IncluL,IncluR)<br /> If ConStr="$False$" or ConStr="" Or StartStr="" Or OverStr="" or IsNull(ConStr)=True or IsNull(StartStr)=True Or IsNull(OverStr)=True Then<br /> GetPaing="$False$"<br /> Exit Function<br /> End If</p> <p>Dim Start,Over,ConTemp,Erri<br /> ConStr=LCase(ConStr)<br /> StartStr=LCase(StartStr)<br /> OverStr=LCase(OverStr)<br /> Over=InstrB(1,ConStr,OverStr,vbBinaryCompare)<br /> If Over<=0 Then<br /> GetPaing="$False$"<br /> Exit Function<br /> Else<br /> Over=Over+Lenb(OverStr)<br /> End If</p> <p>Start=Over-5<br /> If Start<=0 Then<br /> GetPaing="$False$"<br /> Exit Function<br /> End If</p> <p>ConTemp=MidB(ConStr,Start,Over-Start)<br /> Do While InstrB(1,ConTemp,StartStr,vbBinaryCompare)<=0<br /> Erri=Erri+1<br /> If Erri>50 then<br /> GetPaing="$False$"<br /> Exit Function<br /> End If<br /> Start=Start-5<br /> if Start<=0 then<br /> GetPaing="$False$"<br /> Exit Do<br /> Exit Function<br /> Else<br /> ConTemp=MidB(ConStr,Start,Over-Start)<br /> End If<br /> Loop</p> <p>Start=InstrB(1,ConTemp,StartStr,vbBinaryCompare)<br /> If IncluL=False Then<br /> Start=Start+LenB(StartStr)<br /> End If<br /> Over=InstrB(Start,ConTemp,OverStr,vbBinaryCompare)<br /> If IncluR=True Then<br /> Over=Over+LenB(OverStr)<br /> End If<br /> If Start>=Over then<br /> GetPaing="$False$"<br /> Exit Function<br /> End If<br /> GetPaing=MidB(ConTemp,Start,Over-Start)<br /> GetPaing=Trim(GetPaing)<br /> GetPaing=Replace(GetPaing," ","")<br /> GetPaing=Replace(GetPaing,",","")<br /> GetPaing=Replace(GetPaing,"'","")<br /> GetPaing=Replace(GetPaing,"""","")<br /> GetPaing=Replace(GetPaing,">","")<br /> GetPaing=Replace(GetPaing,"<","")<br /> End Function</p> <p>'==================================================<br /> '函数名：ScriptHtml<br /> '作 用：过滤html标记<br /> '参 数：ConStr ------ 要过滤的字符串<br /> '==================================================<br /> Function ScriptHtml(Byval ConStr,TagName,FType)<br /> Dim Re<br /> Set Re=new RegExp<br /> Re.IgnoreCase =true<br /> Re.Global=True<br /> Select Case FType<br /> Case 1<br /> Re.Pattern="<" & TagName & "([^>])*>"<br /> ConStr=Re.Replace(ConStr,"")<br /> Case 2<br /> Re.Pattern="<" & TagName & "([^>])*>.*?</" & TagName & "([^>])*>"<br /> ConStr=Re.Replace(ConStr,"")<br /> Case 3<br /> Re.Pattern="<" & TagName & "([^>])*>"<br /> ConStr=Re.Replace(ConStr,"")<br /> Re.Pattern="</" & TagName & "([^>])*>"<br /> ConStr=Re.Replace(ConStr,"")<br /> End Select<br /> ScriptHtml=ConStr<br /> Set Re=Nothing<br /> End Function</p> <p>Function CheckDir(byval FolderPath)<br /> dim fso<br /> Set fso = Server.CreateObject("Scripting.FileSystemObject")<br /> If fso.FolderExists(Server.MapPath(folderpath)) then<br /> '存在<br /> CheckDir = True<br /> Else<br /> '不存在<br /> CheckDir = False<br /> End if<br /> Set fso = nothing<br /> End Function<br /> Function MakeNewsDir(byval foldername)<br /> dim fso<br /> Set fso = Server.CreateObject("Scripting.FileSystemObject")<br /> fso.CreateFolder(Server.MapPath(foldername))<br /> If fso.FolderExists(Server.MapPath(foldername)) Then<br /> MakeNewsDir = True<br /> Else<br /> MakeNewsDir = False<br /> End If<br /> Set fso = nothing<br /> End Function</p> <p>'**************************************************<br /> '函数名：IsObjInstalled<br /> '作 用：检查组件是否已经安装<br /> '参 数：strClassString ----组件名<br /> '返回值：True ----已经安装<br /> ' False ----没有安装<br /> '**************************************************<br /> Function IsObjInstalled(strClassString)<br /> On Error Resume Next<br /> IsObjInstalled = False<br /> Err = 0<br /> Dim xTestObj<br /> Set xTestObj = Server.CreateObject(strClassString)<br /> If 0 = Err Then IsObjInstalled = True<br /> Set xTestObj = Nothing<br /> Err = 0<br /> End Function</p> <p>'**************************************************<br /> '过程名：WriteErrMsg<br /> '作 用：显示错误提示信息<br /> '参 数：无<br /> '**************************************************<br /> sub WriteErrMsg(ErrMsg)<br /> dim strErr<br /> strErr=strErr & "<html><head><title>错误信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbcrlf<br /> strErr=strErr & "<link href="../admin/Admin_STYLE.CSS" mce_href="admin/Admin_STYLE.CSS" rel='stylesheet' type='text/css'></head><body><br><br>" & vbcrlf<br /> strErr=strErr & "<table cellpadding=2 cellspacing=1 border=0 width=400 class='border' align=center>" & vbcrlf<br /> strErr=strErr & " <tr align='center' class='title'><td height='22'><strong>错误信息</strong></td></tr>" & vbcrlf<br /> strErr=strErr & " <tr class='tdbg'><td height='100' valign='top'><b>产生错误的可能原因：</b>" & ErrMsg &"</td></tr>" & vbcrlf<br /> strErr=strErr & " <tr align='center' class='tdbg'><td><a href="javascript:history.go(-1)" mce_href="javascript:history.go(-1)"><< 返回上一页</a></td></tr>" & vbcrlf<br /> strErr=strErr & "</table>" & vbcrlf<br /> strErr=strErr & "</body></html>" & vbcrlf<br /> response.write strErr<br /> end sub</p> <p>'**************************************************<br /> '过程名：WriteSucced<br /> '作 用：显示成功提示信息<br /> '参 数：无<br /> '**************************************************<br /> sub WriteSucced(ErrMsg)<br /> dim strErr<br /> strErr=strErr & "<html><head><title>成功信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbcrlf<br /> strErr=strErr & "<link href="../admin/Admin_STYLE.CSS" mce_href="admin/Admin_STYLE.CSS" rel='stylesheet' type='text/css'></head><body><br><br>" & vbcrlf<br /> strErr=strErr & "<table cellpadding=2 cellspacing=1 border=0 width=400 class='border' align=center>" & vbcrlf<br /> strErr=strErr & " <tr align='center' class='title'><td height='22'><strong>恭喜你！</strong></td></tr>" & vbcrlf<br /> strErr=strErr & " <tr class='tdbg'><td height='100' valign='top' align='center'>" & ErrMsg &"</td></tr>" & vbcrlf<br /> 'strErr=strErr & " <tr align='center' class='tdbg'><td><a href="javascript:history.go(-1)" mce_href="javascript:history.go(-1)"><< 返回上一页</a></td></tr>" & vbcrlf<br /> strErr=strErr & "</table>" & vbcrlf<br /> strErr=strErr & "</body></html>" & vbcrlf<br /> response.write strErr<br /> end sub</p> <p>'**************************************************<br /> '函数名：ShowPage<br /> '作 用：显示“上一页 下一页”等信息<br /> '参 数：sFileName ----链接地址<br /> ' TotalNumber ----总数量<br /> ' MaxPerPage ----每页数量<br /> ' ShowTotal ----是否显示总数量<br /> ' ShowAllPages ---是否用下拉列表显示所有页面以供跳转。有某些页面不能使用，否则会出现JS错误。<br /> ' strUnit ----计数单位<br /> '返回值：“上一页 下一页”等信息的HTML代码<br /> '**************************************************<br /> function ShowPage(sFileName,TotalNumber,MaxPerPage,ShowTotal,ShowAllPages,strUnit)<br /> dim TotalPage,strTemp,strUrl,i</p> <p> if TotalNumber=0 or MaxPerPage=0 or isNull(MaxPerPage) then<br /> ShowPage=""<br /> exit function<br /> end if<br /> if totalnumber mod maxperpage=0 then<br /> TotalPage= totalnumber / maxperpage<br /> else<br /> TotalPage= totalnumber / maxperpage+1<br /> end if<br /> if CurrentPage>TotalPage then CurrentPage=TotalPage</p> <p> strTemp= "<table align='center'><tr><td>"<br /> if ShowTotal=true then<br /> strTemp=strTemp & "共 <b>" & totalnumber & "</b> " & strUnit & " "<br /> end if<br /> strUrl=JoinChar(sfilename)<br /> if CurrentPage<2 then<br /> strTemp=strTemp & "首页 上一页 "<br /> else<br /> strTemp=strTemp & "<a href="" & strUrl & "page=1" mce_href="" & strUrl & "page=1">首页</a> "<br /> strTemp=strTemp & "<a href="" & strUrl & "page=" & (CurrentPage-1) & "" mce_href="" & strUrl & "page=" & (CurrentPage-1) & "">上一页</a> "<br /> end if</p> <p> if CurrentPage>=TotalPage then<br /> strTemp=strTemp & "下一页 尾页"<br /> else<br /> strTemp=strTemp & "<a href="" & strUrl & "page=" & (CurrentPage+1) & "" mce_href="" & strUrl & "page=" & (CurrentPage+1) & "">下一页</a> "<br /> strTemp=strTemp & "<a href="" & strUrl & "page=" & TotalPage & "" mce_href="" & strUrl & "page=" & TotalPage & "">尾页</a>"<br /> end if<br /> strTemp=strTemp & " 页次：<strong><font color=red>" & CurrentPage & "</font>/" & TotalPage & "</strong>页 "<br /> strTemp=strTemp & " <b>" & maxperpage & "</b>" & strUnit & "/页"<br /> if ShowAllPages=True then<br /> strTemp=strTemp & " 转到第<input type='text' name='page' size='3' maxlength='5' value='" & CurrentPage & "' onKeyPress=""if (event.keyCode==13) window.location='" & strUrl & "page=" & "'+this.value;""'>页"<br /> end if<br /> strTemp=strTemp & "</td></tr></table>"<br /> ShowPage=strTemp<br /> end function</p> <p>'**************************************************<br /> '函数名：JoinChar<br /> '作 用：向地址中加入 ? 或 &<br /> '参 数：strUrl ----网址<br /> '返回值：加了 ? 或 & 的网址<br /> '**************************************************<br /> function JoinChar(strUrl)<br /> if strUrl="" then<br /> JoinChar=""<br /> exit function<br /> end if<br /> if InStr(strUrl,"?")<len(strUrl) then<br /> if InStr(strUrl,"?")>1 then<br /> if InStr(strUrl,"&")<len(strUrl) then<br /> JoinChar=strUrl & "&"<br /> else<br /> JoinChar=strUrl<br /> end if<br /> else<br /> JoinChar=strUrl & "?"<br /> end if<br /> else<br /> JoinChar=strUrl<br /> end if<br /> end function</p> <p>'**************************************************<br /> '函数名：CreateKeyWord<br /> '作 用：由给定的字符串生成关键字<br /> '参 数：Constr---要生成关键字的原字符串<br /> '返回值：生成的关键字<br /> '**************************************************<br /> Function CreateKeyWord(byval Constr)<br /> If Constr="" or IsNull(Constr)=True or Constr="$False$" Then<br /> CreateKeyWord="$False$"<br /> Exit Function<br /> End If<br /> Constr=Replace(Constr,CHR(32),"")<br /> Constr=Replace(Constr,CHR(9),"")<br /> Constr=Replace(Constr," ","")<br /> Constr=Replace(Constr," ","")<br /> Constr=Replace(Constr,"(","")<br /> Constr=Replace(Constr,")","")<br /> Constr=Replace(Constr,"<","")<br /> Constr=Replace(Constr,">","")<br /> Dim i,ConstrTemp<br /> For i=1 To Len(Constr)<br /> ConstrTemp=ConstrTemp & "|" & Mid(Constr,i,2)<br /> Next<br /> If Len(ConstrTemp)<254 Then<br /> ConstrTemp=ConstrTemp & "|"<br /> Else<br /> ConstrTemp=Left(ConstrTemp,254) & "|"<br /> End If<br /> CreateKeyWord=ConstrTemp<br /> End Function</p> <p>Function CheckUrl(strUrl)<br /> Dim Re<br /> Set Re=new RegExp<br /> Re.IgnoreCase =true<br /> Re.Global=True<br /> Re.Pattern="http://([/w-]+/.)+[/w-]+(/[/w-./?%&=]*)?"<br /> If Re.test(strUrl)=True Then<br /> CheckUrl=strUrl<br /> Else<br /> CheckUrl="$False$"<br /> End If<br /> Set Rs=Nothing<br /> End Function<br />
抱歉!评论已关闭.