<%
’==================================================
’函数名：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
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
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,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
Next
If TempStr<> Then
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
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=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
End If
Next
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$)
’去掉重复图片结束
’转换相对图片地址开始
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)
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
Next
Set Re=nothing
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
selec t 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 selec t
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)
Next
If Len(ConstrTemp)<254 Then
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
%>