面包会有的

... ...

日志

关于我

加菲

覆巢之下焉有完卵。出来道上混,迟早是要还的。

文章分类

LOFTER精选

八招诀窍，教你实力撩妹 >

asp+XMLHTTP组件做采集常用函数收集

2008-08-08 00:19:59| 分类：默认分类 | 标签： |举报 |字号大中小订阅

下载LOFTER 我的照片书 |

asp+XMLHTTP组件做采集常用函数

其中的html代码处理函数很管用，写得相当漂亮

<%

'==================================================

'函数名：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("MSXML2.XMLHTTP")

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")

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("adodb.stream")

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("Msxml2.XMLHTTP")

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

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

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

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

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

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

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

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

Else

If Right(ConsultUrl,1)="/" Then

DefiniteUrl=ConsultUrl & PrimitiveUrl

Else

DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl

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

Else

If Right(ConsultUrl,1)="/" Then

DefiniteUrl=ConsultUrl & PrimitiveUrl & "/"

Else

DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl & "/"

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,strInstallDir,strChannelDir,SaveTf,TistUrl)

If ConStr="$False$" or ConStr="" or strInstallDir="" or strChannelDir="" Then

ReplaceSaveRemoteFile=ConStr

Exit Function

End If

Dim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2

Dim Start1,Start2

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

TempArray=Split(TempStr,"$Array$")

TempStr=""

For Tempi=0 To Ubound(TempArray)

Re.Pattern ="src\s*=\s*.+?\.(gif|jpg|bmp|jpeg|psd|png|svg|dxf|wmf|tiff)"

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

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=strInstallDir & strChannelDir & "/UploadFiles/" & year(DtNow) & right("0" & month(DtNow),2) & "/"

Arr_Path=Split(SavePath,"/")

PathTemp=""

For Tempi=0 To Ubound(Arr_Path)

If Tempi=0 Then

PathTemp=Arr_Path(0) & "/"

ElseIf Tempi=Ubound(Arr_Path) Then

Exit For

Else

PathTemp=PathTemp & Arr_Path(Tempi) & "/"

End If

If CheckDir(PathTemp)=False Then

If MakeNewsDir(PathTemp)=False Then

SaveTf=False

Exit For

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

TempArray=Split(TempStr,"$Array$")

'去掉重复图片结束

'转换相对图片地址开始

TempStr=""

For Tempi=0 To Ubound(TempArray)

TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)

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)

If SaveRemoteFile(SavePath & strFileName,RemoteFileUrl)=True Then

PathTemp=Replace(SavePath &strFileName,strInstallDir & strChannelDir & "/","[InstallDir_ChannelDir]")

ConStr=Re.Replace(ConStr,PathTemp)

Re.Pattern=strInstallDir & strChannelDir & "/"

UploadFiles=UploadFiles & "|" & Re.Replace(SavePath &strFileName,"")

Else

PathTemp=RemoteFileUrl

ConStr=Re.Replace(ConStr,PathTemp)

'UploadFiles=UploadFiles & "|" & RemoteFileUrl

End If

ElseIf RemoteFileurl<>"$False$" and SaveTf=False Then'不保存图片

Re.Pattern =TempArray(Tempi)

ConStr=Re.Replace(ConStr,RemoteFileUrl)

UploadFiles=UploadFiles & "|" & RemoteFileUrl

End If

If UploadFiles<>"" Then

UploadFiles=Right(UploadFiles,Len(UploadFiles)-1)

End If

ReplaceSaveRemoteFile=ConStr

End function

'==================================================

'过程名：SaveRemoteFile

'作用：保存远程的文件到本地

'参数：LocalFileName ------ 本地文件名

'参数：RemoteFileUrl ------ 远程文件URL

'==================================================

Function SaveRemoteFile(LocalFileName,RemoteFileUrl)

On error resume next

SaveRemoteFile=True

dim Ads,Retrieval,GetRemoteData

Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")

With Retrieval

.Open "Get", RemoteFileUrl, False, "", ""

.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

'==================================================

'函数名：FpHtmlEnCode

'作用：标题过滤

'参数：fString ------字符串

'==================================================

Function FpHtmlEnCode(fString)

If IsNull(fString)=False or fString<>"" or fString<>"$False$" Then

fString=nohtml(fString)

fString=FilterJS(fString)

fString = Replace(fString, CHR(9), "")

fString = Replace(fString, CHR(34), "")

fString = Replace(fString, CHR(39), "")

fString = Replace(fString, CHR(13), "")

fString = Replace(fString, CHR(10), " ")

fString=Trim(fString)

fString=dvhtmlencode(fString)

FpHtmlEnCode=fString

Else

FpHtmlEnCode="$False$"

End If

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,Erri

ConStr=LCase(ConStr)

StartStr=LCase(StartStr)

OverStr=LCase(OverStr)

Over=InstrB(1,ConStr,OverStr,vbBinaryCompare)

If Over<=0 Then

GetPaing="$False$"

Exit Function

Else

Over=Over+Lenb(OverStr)

End If

Start=Over-5

If Start<=0 Then

GetPaing="$False$"

Exit Function

End If

ConTemp=MidB(ConStr,Start,Over-Start)

Do While InstrB(1,ConTemp,StartStr,vbBinaryCompare)<=0

Erri=Erri+1

If Erri>50 then

GetPaing="$False$"

Exit Function

End If

Start=Start-5

if Start<=0 then

GetPaing="$False$"

Exit Do

Exit Function

Else

ConTemp=MidB(ConStr,Start,Over-Start)

End If

Loop

Start=InstrB(1,ConTemp,StartStr,vbBinaryCompare)

If IncluL=False Then

Start=Start+LenB(StartStr)

End If

Over=InstrB(Start,ConTemp,OverStr,vbBinaryCompare)

If IncluR=True Then

Over=Over+LenB(OverStr)

End If

If Start>=Over then

GetPaing="$False$"

Exit Function

End If

GetPaing=MidB(ConTemp,Start,Over-Start)

GetPaing=Trim(GetPaing)

GetPaing=Replace(GetPaing," ","")

GetPaing=Replace(GetPaing,",","")

GetPaing=Replace(GetPaing,"'","")

GetPaing=Replace(GetPaing,"""","")

GetPaing=Replace(GetPaing,">","")

GetPaing=Replace(GetPaing,"<","")

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

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

Function MakeNewsDir(byval foldername)

dim fso

Set fso = Server.CreateObject("Scripting.FileSystemObject")

fso.CreateFolder(Server.MapPath(foldername))

If fso.FolderExists(Server.MapPath(foldername)) Then

MakeNewsDir = True

Else

MakeNewsDir = False

End If

Set fso = nothing

End Function

'**************************************************

'函数名：IsObjInstalled

'作用：检查组件是否已经安装

'参数：strClassString ----组件名

'返回值：True ----已经安装

' False ----没有安装

'**************************************************

Function IsObjInstalled(strClassString)

On Error Resume Next

IsObjInstalled = False

Err = 0

Dim xTestObj

Set xTestObj = Server.CreateObject(strClassString)

If 0 = Err Then IsObjInstalled = True

Set xTestObj = Nothing

Err = 0

End Function

'**************************************************

'过程名：WriteErrMsg

'作用：显示错误提示信息

'参数：无

'**************************************************

sub WriteErrMsg(ErrMsg)

dim strErr

strErr=strErr & "<html><head><title>错误信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbcrlf

strErr=strErr & "<link href='../admin/Admin_STYLE.CSS' rel='stylesheet' type='text/css'></head><body><br><br>" & vbcrlf

strErr=strErr & "<table cellpadding=2 cellspacing=1 border=0 width=400 class='border' align=center>" & vbcrlf

strErr=strErr & " <tr align='center' class='title'><td height='22'><strong>错误信息</strong></td></tr>" & vbcrlf

strErr=strErr & " <tr class='tdbg'><td height='100' valign='top'><b>产生错误的可能原因：</b>" & ErrMsg &"</td></tr>" & vbcrlf

strErr=strErr & " <tr align='center' class='tdbg'><td><a href='javascript:history.go(-1)'><< 返回上一页</a></td></tr>" & vbcrlf

strErr=strErr & "</table>" & vbcrlf

strErr=strErr & "</body></html>" & vbcrlf

response.write strErr

end sub

'**************************************************

'过程名：WriteSucced

'作用：显示成功提示信息

'参数：无

'**************************************************

sub WriteSucced(ErrMsg)

dim strErr

strErr=strErr & "<html><head><title>成功信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbcrlf

strErr=strErr & "<link href='../admin/Admin_STYLE.CSS' rel='stylesheet' type='text/css'></head><body><br><br>" & vbcrlf

strErr=strErr & "<table cellpadding=2 cellspacing=1 border=0 width=400 class='border' align=center>" & vbcrlf

strErr=strErr & " <tr align='center' class='title'><td height='22'><strong>恭喜你！</strong></td></tr>" & vbcrlf

strErr=strErr & " <tr class='tdbg'><td height='100' valign='top' align='center'>" & ErrMsg &"</td></tr>" & vbcrlf

'strErr=strErr & " <tr align='center' class='tdbg'><td><a href='javascript:history.go(-1)'><< 返回上一页</a></td></tr>" & vbcrlf

strErr=strErr & "</table>" & vbcrlf

strErr=strErr & "</body></html>" & vbcrlf

response.write strErr

end sub

'**************************************************

'函数名：ShowPage

'参数：sFileName ----链接地址

' TotalNumber ----总数量

' MaxPerPage ----每页数量

' ShowTotal ----是否显示总数量

' ShowAllPages ---是否用下拉列表显示所有页面以供跳转。有某些页面不能使用，否则会出现JS错误。

' strUnit ----计数单位

'返回值：“上一页下一页”等信息的HTML代码

'**************************************************

function ShowPage(sFileName,TotalNumber,MaxPerPage,ShowTotal,ShowAllPages,strUnit)

dim TotalPage,strTemp,strUrl,i

if TotalNumber=0 or MaxPerPage=0 or isNull(MaxPerPage) then

ShowPage=""

exit function

end if

if totalnumber mod maxperpage=0 then

TotalPage= totalnumber \ maxperpage

else

TotalPage= totalnumber \ maxperpage+1

end if

if CurrentPage>TotalPage then CurrentPage=TotalPage

strTemp= "<table align='center'><tr><td>"

if ShowTotal=true then

strTemp=strTemp & "共 <b>" & totalnumber & "</b> " & strUnit & "  "

end if

strUrl=JoinChar(sfilename)

if CurrentPage<2 then

strTemp=strTemp & "首页上一页 "

else

strTemp=strTemp & "<a href='" & strUrl & "page=1'>首页</a> "

strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage-1) & "'>上一页</a> "

end if

if CurrentPage>=TotalPage then

strTemp=strTemp & "下一页尾页"

else

strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage+1) & "'>下一页</a> "

strTemp=strTemp & "<a href='" & strUrl & "page=" & TotalPage & "'>尾页</a>"

end if

strTemp=strTemp & " 页次：<strong><font color=red>" & CurrentPage & "</font>/" & TotalPage & "</strong>页 "

strTemp=strTemp & " <b>" & maxperpage & "</b>" & strUnit & "/页"

if ShowAllPages=True then

strTemp=strTemp & "  转到第<input type='text' name='page' size='3' maxlength='5' value='" & CurrentPage & "' onKeyPress=""if (event.keyCode==13) window.location='" & strUrl & "page=" & "'+this.value;""'>页"

end if

strTemp=strTemp & "</td></tr></table>"

ShowPage=strTemp

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)

If Constr="" or IsNull(Constr)=True or Constr="$False$" Then

CreateKeyWord="$False$"

Exit Function

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,">","")

Dim i,ConstrTemp

For i=1 To Len(Constr)

ConstrTemp=ConstrTemp & "|" & Mid(Constr,i,2)

ConstrTemp=ConstrTemp & "|"

Else

ConstrTemp=Left(ConstrTemp,254) & "|"

End If

CreateKeyWord=ConstrTemp

End Function

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

%>

评论这张

转发至微博

阅读(688)| 评论(0)

历史上的今天

在LOFTER的更多文章

this.p={  m:2,
              b:2,
              loftPermalink:'',
              id:'fks_085067084082085075083087095095087094083071081081087071',
              blogTitle:'asp+XMLHTTP组件做采集常用函数收集',
              blogAbstract:'<P style=\"TEXT-INDENT: 2em;\"  \>asp+XMLHTTP组件做采集常用函数</P\>  <P style=\"TEXT-INDENT: 2em;\"  \>其中的html代码处理函数很管用，写得相当漂亮</P\>  <P style=\"TEXT-INDENT: 2em;\"  \><%</P\>  <P style=\"TEXT-INDENT: 2em;\"  \>\'==================================================</P\>  <P style=\"TEXT-INDENT: 2em;\"  \>\'函数名：GetHttpPage</P\>  <P style=\"TEXT-INDENT: 2em;\"  \>\'作 用：获取网页源码</P\>  <P style=\"TEXT-INDENT: 2em;\"  \>\'参 数：HttpUrl ------网页地址</P\>  <P style=\"TEXT-INDENT: 2em;\"  \>\'==================================================</P\>  <P style=\"TEXT-INDENT: 2em;\"  \>Function GetHttpPage(HttpUrl)</P\>  <P style=\"TEXT-INDENT: 2em;\"  \>If IsNull(HttpUrl)=True Or Len(HttpUrl)<18 Or HttpUrl=\"$False$\" Then</P\>',
              blogTag:'',
              blogUrl:'blog/static/3824571420087801959670',
              isPublished:1,
              istop:false,
              type:2,
              modifyTime:1317444601023,
              publishTime:1218125999670,
              permalink:'blog/static/3824571420087801959670',
              commentCount:0,
              mainCommentCount:0,
              recommendCount:0,
              bsrk:-100,
              publisherId:0,
              recomBlogHome:false,
              currentRecomBlog:false,
              attachmentsFileIds:[],
              vote:{},
              groupInfo:{},
              friendstatus:'none',
              followstatus:'unFollow',
              pubSucc:'',
              visitorProvince:'',
              visitorCity:'',
              visitorNewUser:false,
              postAddInfo:{},
              mset:'000',
              mcon:'',
              srk:-100,
              remindgoodnightblog:false,
              isBlackVisitor:false,
              isShowYodaoAd:true,
              hostIntro:'覆巢之下焉有完卵。\n出来道上混,迟早是要还的。',
              hmcon:'1',
              selfRecomBlogCount:'0',
              lofter_single:'<iframe width="140" height="560" style="overflow:hidden;" src="http://www.lofter.com/mailEntry.do?blogad=1&blog" frameBorder="0"></iframe>'
            }

{list a as x}
    {if !!x}
    <div class="iblock nbw-fce nbw-f40">
      <a class="fc03 noul" target="_blank" hidefocus="true" href="http://blog.163.com/${x.visitorName}/">
      {if x.visitorName==visitor.userName}
      <img alt="${x.visitorNickname|escape}" onerror="this.src=location.f40" class="cwd bdwa bdc0" src="${fn1(x.visitorName)}&r=${visitor.imageUpdateTime}"/>
      {else}
      <img alt="${x.visitorNickname|escape}" onerror="this.src=location.f40" class="cwd bdwa bdc0" src="${fn1(x.visitorName)}"/>
      {/if}
      </a>
      <div class="cwd vname thide">
        {if x.moveFrom=='wap'}
          <a class="noul pnt" target="_blank" href="http://blog.163.com/services/wapblog.html?frompersonalbloghome"><span title="来自网易手机博客" class="iblock wapIcon"> </span></a>
        {elseif x.moveFrom=='iphone'}
          <a class="noul pnt" target="_blank"><span title="来自iPhone客户端" class="iblock iphoneIcon"> </span></a>
        {elseif x.moveFrom=='android'}
          <a class="noul pnt" target="_blank"><span title="来自Android客户端" class="iblock androidIcon"> </span></a>
        {elseif x.moveFrom=='mobile'}
          <a class="noul pnt" target="_blank" href="http://blog.163.com/services/emsblog.html?frompersonalbloghome"><span title="来自网易短信写博" class="iblock wapIcon"> </span></a>
        {/if}
        <a class="fc03 m2a"  target="_blank" hidefocus="true" href="http://blog.163.com/${x.visitorName}/">
          ${fn(x.visitorNickname,8)|escape}
        </a>
      </div>
    </div>
    {/if}
    {/list}

<#--最新日志，群博日志--> <#--推荐日志-->

<p class="fc06">推荐过这篇日志的人：</p>
    <div>
      {list a as x}
      {if !!x}
      <div class="iblock nbw-fce nbw-f40">
        <a class="fc03 noul" target="_blank" hidefocus="true" href="http://blog.163.com/${x.recommenderName}/">
        <img alt="${x.recommenderNickname|escape}" onerror="this.src=location.f40" class="cwd bdwa bdc0" src="${fn1(x.recommenderName)}"/>
        </a>
        <div class="cwd thide">
          <a class="fc03 m2a" target="_blank" hidefocus="true" href="http://blog.163.com/${x.recommenderName}/">
            ${fn(x.recommenderNickname,6)|escape}
          </a>
        </div>
      </div>
      {/if}
      {/list}
    </div>
    {if !!b&&b.length>0}
    <p  class="fc06">他们还推荐了：</p>
    <ul>
    {list b as y}
      {if !!y}
        <li class="rrb"><span class="iblock">·</span><a class="fc03 m2a" target="_blank" href="http://blog.163.com/${y.recommendBlogPermalink}/?from=blog/static/3824571420087801959670">${y.recommendBlogTitle|escape}</a></li>
      {/if}
    {/list}
    </ul>
    {/if}

<#--引用记录--> <#--博主推荐--> <#--随机阅读--> <#--首页推荐--> <#--历史上的今天--> <#--被推荐日志--> <#--上一篇，下一篇--> <#-- 热度 -->

{list a as x}
    {if !!x}
    <div class="hotItem iblock nbw-fce nbw-f40">
      <a class="fc03 noul" target="_blank" hidefocus="true" href="http://blog.163.com/${x.publisherUsername}/">
      {if x.publisherUsername==visitor.userName}
      <img alt="${x.publisherNickname|escape}" onerror="this.src=location.f40" class="cwd bdwa bdc0" src="${fn1(x.publisherUsername)}&r=${visitor.imageUpdateTime}"/>
      {else}
      <img alt="${x.publisherNickname|escape}" onerror="this.src=location.f40" class="cwd bdwa bdc0" src="${fn1(x.publisherUsername)}"/>
      {/if}
      </a>
      <div class="cwd vname thide">
        <a class="fc03 m2a"  target="_blank" hidefocus="true" href="http://blog.163.com/${x.publisherUsername}/">
          ${fn(x.publisherNickname,8)|escape}
        </a>
      </div>
      <a class="f-myLikeIcons hottype {if x.type==1} js-liketype{elseif x.type==2} js-reblogtype{elseif x.type==3} js-sharetype{else}{/if}" target="_blank" hidefocus="true" href="http://blog.163.com/${x.publisherUsername}/"> </a>
    </div>
    {/if}
    {/list}

<#-- 网易新闻广告 --> <#--右边模块结构--> <#--评论模块结构--> <#--引用模块结构--> <#--博主发起的投票-->

页脚

我的照片书 - 博客风格 - 手机博客 - 下载LOFTER APP - 订阅此博客

面包会有的

导航

日志

asp+XMLHTTP组件做采集常用函数收集

历史上的今天

最近读者

热度

在LOFTER的更多文章

评论

页脚