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
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 & "/","/web/")
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
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)
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
%>