asp+XMLHTTP组件做采集常用函数收集
asp+XMLHTTP组件做采集常用函数
其中的html代码处理函数很管用，写得相当漂亮
<%
'==================================================
'函数名：GetHttpPage
'作用：获取网页源码
'参数：HttpUrl------网页地址
'==================================================
FunctionGetHttpPage(HttpUrl)
IfIsNull(HttpUrl)=TrueorLen(HttpUrl)<18orHttpUrl="$False$"Then
GetHttpPage="$False$"
ExitFunction
EndIf
DimHttp
SetHttp=server.createobject("MSXML2.XMLHTTP")
Http.open"GET",HttpUrl,False
Http.Send()
IfHttp.Readystate<>4then
SetHttp=Nothing
GetHttpPage="$False$"
Exitfunction
Endif
GetHTTPPage=bytesToBSTR(Http.responseBody,"GB2312")
SetHttp=Nothing
IfErr.number<>0then
Err.Clear
EndIf
EndFunction
'==================================================
'函数名：BytesToBstr
'作用：将获取的源码转换为中文
'参数：Body------要转换的变量
'参数：Cset------要转换的类型
'==================================================
FunctionBytesToBstr(Body,Cset)
DimObjstream
SetObjstream=Server.CreateObject("adodb.stream")
objstream.Type=1
objstream.Mode=3
objstream.Open
objstream.Writebody
objstream.Position=0
objstream.Type=2
objstream.Charset=Cset
BytesToBstr=objstream.ReadText
objstream.Close
setobjstream=nothing
EndFunction
'==================================================
'函数名：PostHttpPage
'作用：登录
'==================================================
FunctionPostHttpPage(RefererUrl,PostUrl,PostData)
DimxmlHttp
DimRetStr
SetxmlHttp=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.SendPostData
IfErr.Number<>0Then
SetxmlHttp=Nothing
PostHttpPage="$False$"
ExitFunction
EndIf
PostHttpPage=bytesToBSTR(xmlHttp.responseBody,"GB2312")
SetxmlHttp=nothing
EndFunction
'==================================================
'函数名：UrlEncoding
'作用：转换编码
'==================================================
FunctionUrlEncoding(DataStr)
DimStrReturn,Si,ThisChr,InnerCode,Hight8,Low8
StrReturn=""
ForSi=1ToLen(DataStr)
ThisChr=Mid(DataStr,Si,1)
IfAbs(Asc(ThisChr))<&HFFThen
StrReturn=StrReturn&ThisChr
Else
InnerCode=Asc(ThisChr)
IfInnerCode<0Then
InnerCode=InnerCode+&H10000
EndIf
Hight8=(InnerCodeAnd&HFF00)\&HFF
Low8=InnerCodeAnd&HFF
StrReturn=StrReturn&"%"&Hex(Hight8)&"%"&Hex(Low8)
EndIf
Next
UrlEncoding=StrReturn
EndFunction
'==================================================
'函数名：GetBody
'作用：截取字符串
'参数：ConStr------将要截取的字符串
'参数：StartStr------开始字符串
'参数：OverStr------结束字符串
'参数：IncluL------是否包含StartStr
'参数：IncluR------是否包含OverStr
'==================================================
FunctionGetBody(ConStr,StartStr,OverStr,IncluL,IncluR)
IfConStr="$False$"orConStr=""orIsNull(ConStr)=TrueorStartStr=""orIsNull(StartStr)=TrueorOverStr=""orIsNull(OverStr)=TrueThen
GetBody="$False$"
ExitFunction
EndIf
DimConStrTemp
DimStart,Over
ConStrTemp=Lcase(ConStr)
StartStr=Lcase(StartStr)
OverStr=Lcase(OverStr)
Start=InStrB(1,ConStrTemp,StartStr,vbBinaryCompare)
IfStart<=0then
GetBody="$False$"
ExitFunction
Else
IfIncluL=FalseThen
Start=Start+LenB(StartStr)
EndIf
EndIf
Over=InStrB(Start,ConStrTemp,OverStr,vbBinaryCompare)
IfOver<=0orOver<=Startthen
GetBody="$False$"
ExitFunction
Else
IfIncluR=TrueThen
Over=Over+LenB(OverStr)
EndIf
EndIf
GetBody=MidB(ConStr,Start,Over-Start)
EndFunction
'==================================================
'函数名：GetArray
'作用：提取链接地址，以$Array$分隔
'参数：ConStr------提取地址的原字符
'参数：StartStr------开始字符串
'参数：OverStr------结束字符串
'参数：IncluL------是否包含StartStr
'参数：IncluR------是否包含OverStr
'==================================================
FunctionGetArray(ByvalConStr,StartStr,OverStr,IncluL,IncluR)
IfConStr="$False$"orConStr=""orIsNull(ConStr)=TrueorStartStr=""orOverStr=""orIsNull(StartStr)=TrueorIsNull(OverStr)=TrueThen
GetArray="$False$"
ExitFunction
EndIf
DimTempStr,TempStr2,objRegExp,Matches,Match
TempStr=""
SetobjRegExp=NewRegexp
objRegExp.IgnoreCase=True
objRegExp.Global=True
objRegExp.Pattern="("&StartStr&").+?("&OverStr&")"
SetMatches=objRegExp.Execute(ConStr)
ForEachMatchinMatches
TempStr=TempStr&"$Array$"&Match.Value
Next
SetMatches=nothing
IfTempStr=""Then
GetArray="$False$"
ExitFunction
EndIf
TempStr=Right(TempStr,Len(TempStr)-7)
IfIncluL=Falsethen
objRegExp.Pattern=StartStr
TempStr=objRegExp.Replace(TempStr,"")
Endif
IfIncluR=Falsethen
objRegExp.Pattern=OverStr
TempStr=objRegExp.Replace(TempStr,"")
Endif
SetobjRegExp=nothing
TempStr=Replace(TempStr,"""","")
TempStr=Replace(TempStr,"'","")
TempStr=Replace(TempStr,"","")
IfTempStr=""then
GetArray="$False$"
Else
GetArray=TempStr
Endif
EndFunction
'==================================================
'函数名：DefiniteUrl
'作用：将相对地址转换为绝对地址
'参数：PrimitiveUrl------要转换的相对地址
'参数：ConsultUrl------当前网页地址
'==================================================
FunctionDefiniteUrl(ByvalPrimitiveUrl,ByvalConsultUrl)
DimConTemp,PriTemp,Pi,Ci,PriArray,ConArray
IfPrimitiveUrl=""orConsultUrl=""orPrimitiveUrl="$False$"orConsultUrl="$False$"Then
DefiniteUrl="$False$"
ExitFunction
EndIf
IfLeft(Lcase(ConsultUrl),7)<>" http://"Then
ConsultUrl=" http://"&ConsultUrl
EndIf
ConsultUrl=Replace(ConsultUrl,"\","/")
ConsultUrl=Replace(ConsultUrl,"://",":\\")
PrimitiveUrl=Replace(PrimitiveUrl,"\","/")
IfRight(ConsultUrl,1)<>"/"Then
IfInstr(ConsultUrl,"/")>0Then
IfInstr(Right(ConsultUrl,Len(ConsultUrl)-InstrRev(ConsultUrl,"/")),".")>0then
Else
ConsultUrl=ConsultUrl&"/"
EndIf
Else
ConsultUrl=ConsultUrl&"/"
EndIf
EndIf
ConArray=Split(ConsultUrl,"/")
IfLeft(LCase(PrimitiveUrl),7)=" http://"then
DefiniteUrl=Replace(PrimitiveUrl,"://",":\\")
ElseIfLeft(PrimitiveUrl,1)="/"Then
DefiniteUrl=ConArray(0)&PrimitiveUrl
ElseIfLeft(PrimitiveUrl,2)="./"Then
PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-2)
IfRight(ConsultUrl,1)="/"Then
DefiniteUrl=ConsultUrl&PrimitiveUrl
Else
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/"))&PrimitiveUrl
EndIf
ElseIfLeft(PrimitiveUrl,3)="../"then
DoWhileLeft(PrimitiveUrl,3)="../"
PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-3)
Pi=Pi+1
Loop
ForCi=0to(Ubound(ConArray)-1-Pi)
IfDefiniteUrl<>""Then
DefiniteUrl=DefiniteUrl&"/"&ConArray(Ci)
Else
DefiniteUrl=ConArray(Ci)
EndIf
Next
DefiniteUrl=DefiniteUrl&"/"&PrimitiveUrl
Else
IfInstr(PrimitiveUrl,"/")>0Then
PriArray=Split(PrimitiveUrl,"/")
IfInstr(PriArray(0),".")>0Then
IfRight(PrimitiveUrl,1)="/"Then
DefiniteUrl="http:\\"&PrimitiveUrl
Else
IfInstr(PriArray(Ubound(PriArray)-1),".")>0Then
DefiniteUrl="http:\\"&PrimitiveUrl
Else
DefiniteUrl="http:\\"&PrimitiveUrl&"/"
EndIf
EndIf
Else
IfRight(ConsultUrl,1)="/"Then
DefiniteUrl=ConsultUrl&PrimitiveUrl
Else
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/"))&PrimitiveUrl
EndIf
EndIf
Else
IfInstr(PrimitiveUrl,".")>0Then
IfRight(ConsultUrl,1)="/"Then
Ifright(LCase(PrimitiveUrl),3)=".cn"orright(LCase(PrimitiveUrl),3)="com"orright(LCase(PrimitiveUrl),3)="net"orright(LCase(PrimitiveUrl),3)="org"Then
DefiniteUrl="http:\\"&PrimitiveUrl&"/"
Else
DefiniteUrl=ConsultUrl&PrimitiveUrl
EndIf
Else
Ifright(LCase(PrimitiveUrl),3)=".cn"orright(LCase(PrimitiveUrl),3)="com"orright(LCase(PrimitiveUrl),3)="net"orright(LCase(PrimitiveUrl),3)="org"Then
DefiniteUrl="http:\\"&PrimitiveUrl&"/"
Else
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/"))&"/"&PrimitiveUrl
EndIf
EndIf
Else
IfRight(ConsultUrl,1)="/"Then
DefiniteUrl=ConsultUrl&PrimitiveUrl&"/"
Else
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/"))&"/"&PrimitiveUrl&"/"
EndIf
EndIf
EndIf
EndIf
IfLeft(DefiniteUrl,1)="/"then
DefiniteUrl=Right(DefiniteUrl,Len(DefiniteUrl)-1)
Endif
IfDefiniteUrl<>""Then
DefiniteUrl=Replace(DefiniteUrl,"//","/")
DefiniteUrl=Replace(DefiniteUrl,":\\","://")
Else
DefiniteUrl="$False$"
EndIf
EndFunction
'==================================================
'函数名：ReplaceSaveRemoteFile
'作用：替换、保存远程图片
'参数：ConStr------要替换的字符串
'参数：SaveTf------是否保存文件，False不保存，True保存
'参数:TistUrl------当前网页地址
'==================================================
FunctionReplaceSaveRemoteFile(ConStr,strInstallDir,strChannelDir,SaveTf,TistUrl)
IfConStr="$False$"orConStr=""orstrInstallDir=""orstrChannelDir=""Then
ReplaceSaveRemoteFile=ConStr
ExitFunction
EndIf
DimTempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2
DimStart1,Start2
SetRe=NewRegexp
Re.IgnoreCase=True
Re.Global=True
Re.Pattern="<img.+?[^\>]>"
SetMatches=Re.Execute(ConStr)
ForEachMatchinMatches
IfTempStr<>""then
TempStr=TempStr&"$Array$"&Match.Value
Else
TempStr=Match.Value
Endif
Next
IfTempStr<>""Then
TempArray=Split(TempStr,"$Array$")
TempStr=""
ForTempi=0ToUbound(TempArray)
Re.Pattern="src\s*=\s*.+?\.(gif|jpg|bmp|jpeg|psd|png|svg|dxf|wmf|tiff)"
SetMatches=Re.Execute(TempArray(Tempi))
ForEachMatchinMatches
IfTempStr<>""then
TempStr=TempStr&"$Array$"&Match.Value
Else
TempStr=Match.Value
Endif
Next
Next
Endif
IfTempStr<>""Then
Re.Pattern="src\s*=\s*"
TempStr=Re.Replace(TempStr,"")
EndIf
SetMatches=nothing
SetRe=nothing
IfTempStr=""orIsNull(TempStr)=TrueThen
ReplaceSaveRemoteFile=ConStr
Exitfunction
Endif
TempStr=Replace(TempStr,"""","")
TempStr=Replace(TempStr,"'","")
TempStr=Replace(TempStr,"","")
DimRemoteFileurl,SavePath,PathTemp,DtNow,strFileName,strFileType,ArrSaveFileName,RanNum,Arr_Path
DtNow=Now()
IfSaveTf=Truethen
SavePath=strInstallDir&strChannelDir&"/UploadFiles/"&year(DtNow)&right("0"&month(DtNow),2)&"/"
Arr_Path=Split(SavePath,"/")
PathTemp=""
ForTempi=0ToUbound(Arr_Path)
IfTempi=0Then
PathTemp=Arr_Path(0)&"/"
ElseIfTempi=Ubound(Arr_Path)Then
ExitFor
Else
PathTemp=PathTemp&Arr_Path(Tempi)&"/"
EndIf
IfCheckDir(PathTemp)=FalseThen
IfMakeNewsDir(PathTemp)=FalseThen
SaveTf=False
ExitFor
EndIf
EndIf
Next
EndIf
'去掉重复图片开始
TempArray=Split(TempStr,"$Array$")
TempStr=""
ForTempi=0ToUbound(TempArray)
IfInstr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1Then
TempStr=TempStr&"$Array$"&TempArray(Tempi)
EndIf
Next
TempStr=Right(TempStr,Len(TempStr)-7)
TempArray=Split(TempStr,"$Array$")
'去掉重复图片结束
'转换相对图片地址开始
TempStr=""
ForTempi=0ToUbound(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=""
'转换相对图片地址结束
'图片替换/保存
SetRe=NewRegexp
Re.IgnoreCase=True
Re.Global=True
ForTempi=0ToUbound(TempArray2)
RemoteFileUrl=TempArray2(Tempi)
IfRemoteFileUrl<>"$False$"AndSaveTf=TrueThen'保存图片
ArrSaveFileName=Split(RemoteFileurl,".")
strFileType=Lcase(ArrSaveFileName(Ubound(ArrSaveFileName)))'文件类型
IfstrFileType="asp"orstrFileType="asa"orstrFileType="aspx"orstrFileType="cer"orstrFileType="cdx"orstrFileType="exe"orstrFileType="rar"orstrFileType="zip"then
UploadFiles=""
ReplaceSaveRemoteFile=ConStr
ExitFunction
EndIf
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)
IfSaveRemoteFile(SavePath&strFileName,RemoteFileUrl)=TrueThen
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
EndIf
ElseIfRemoteFileurl<>"$False$"andSaveTf=FalseThen'不保存图片
Re.Pattern=TempArray(Tempi)
ConStr=Re.Replace(ConStr,RemoteFileUrl)
UploadFiles=UploadFiles&"|"&RemoteFileUrl
EndIf
Next
SetRe=nothing
IfUploadFiles<>""Then
UploadFiles=Right(UploadFiles,Len(UploadFiles)-1)
EndIf
ReplaceSaveRemoteFile=ConStr
Endfunction
'==================================================
'过程名：SaveRemoteFile
'作用：保存远程的文件到本地
'参数：LocalFileName------本地文件名
'参数：RemoteFileUrl------远程文件URL
'==================================================
FunctionSaveRemoteFile(LocalFileName,RemoteFileUrl)
Onerrorresumenext
SaveRemoteFile=True
dimAds,Retrieval,GetRemoteData
SetRetrieval=Server.CreateObject("Microsoft.XMLHTTP")
WithRetrieval
.Open"Get",RemoteFileUrl,False,"",""
.Send
If.Readystate<>4then
SaveRemoteFile=False
ExitFunction
EndIf
GetRemoteData=.ResponseBody
EndWith
SetRetrieval=Nothing
SetAds=Server.CreateObject("Adodb.Stream")
WithAds
.Type=1
.Open
.WriteGetRemoteData
.SaveToFileserver.MapPath(LocalFileName),2
.Cancel()
.Close()
EndWith
SetAds=nothing
endFunction
'==================================================
'函数名：FpHtmlEnCode
'作用：标题过滤
'参数：fString------字符串
'==================================================
FunctionFpHtmlEnCode(fString)
IfIsNull(fString)=FalseorfString<>""orfString<>"$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$"
EndIf
EndFunction
'==================================================
'函数名：GetPaing
'作用：获取分页
'==================================================
FunctionGetPaing(ByvalConStr,StartStr,OverStr,IncluL,IncluR)
IfConStr="$False$"orConStr=""orStartStr=""orOverStr=""orIsNull(ConStr)=TrueorIsNull(StartStr)=TrueorIsNull(OverStr)=TrueThen
GetPaing="$False$"
ExitFunction
EndIf
DimStart,Over,ConTemp,Erri
ConStr=LCase(ConStr)
StartStr=LCase(StartStr)
OverStr=LCase(OverStr)
Over=InstrB(1,ConStr,OverStr,vbBinaryCompare)
IfOver<=0Then
GetPaing="$False$"
ExitFunction
Else
Over=Over+Lenb(OverStr)
EndIf
Start=Over-5
IfStart<=0Then
GetPaing="$False$"
ExitFunction
EndIf
ConTemp=MidB(ConStr,Start,Over-Start)
DoWhileInstrB(1,ConTemp,StartStr,vbBinaryCompare)<=0
Erri=Erri+1
IfErri>50then
GetPaing="$False$"
ExitFunction
EndIf
Start=Start-5
ifStart<=0then
GetPaing="$False$"
ExitDo
ExitFunction
Else
ConTemp=MidB(ConStr,Start,Over-Start)
EndIf
Loop
Start=InstrB(1,ConTemp,StartStr,vbBinaryCompare)
IfIncluL=FalseThen
Start=Start+LenB(StartStr)
EndIf
Over=InstrB(Start,ConTemp,OverStr,vbBinaryCompare)
IfIncluR=TrueThen
Over=Over+LenB(OverStr)
EndIf
IfStart>=Overthen
GetPaing="$False$"
ExitFunction
EndIf
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,"<","")
EndFunction
'==================================================
'函数名：ScriptHtml
'作用：过滤html标记
'参数：ConStr------要过滤的字符串
'==================================================
FunctionScriptHtml(ByvalConStr,TagName,FType)
DimRe
SetRe=newRegExp
Re.IgnoreCase=true
Re.Global=True
SelectCaseFType
Case1
Re.Pattern="<"&TagName&"([^>])*>"
ConStr=Re.Replace(ConStr,"")
Case2
Re.Pattern="<"&TagName&"([^>])*>.*?</"&TagName&"([^>])*>"
ConStr=Re.Replace(ConStr,"")
Case3
Re.Pattern="<"&TagName&"([^>])*>"
ConStr=Re.Replace(ConStr,"")
Re.Pattern="</"&TagName&"([^>])*>"
ConStr=Re.Replace(ConStr,"")
EndSelect
ScriptHtml=ConStr
SetRe=Nothing
EndFunction
FunctionCheckDir(byvalFolderPath)
dimfso
Setfso=Server.CreateObject("Scripting.FileSystemObject")
Iffso.FolderExists(Server.MapPath(folderpath))then
'存在
CheckDir=True
Else
'不存在
CheckDir=False
Endif
Setfso=nothing
EndFunction
FunctionMakeNewsDir(byvalfoldername)
dimfso
Setfso=Server.CreateObject("Scripting.FileSystemObject")
fso.CreateFolder(Server.MapPath(foldername))
Iffso.FolderExists(Server.MapPath(foldername))Then
MakeNewsDir=True
Else
MakeNewsDir=False
EndIf
Setfso=nothing
EndFunction
'**************************************************
'函数名：IsObjInstalled
'作用：检查组件是否已经安装
'参数：strClassString----组件名
'返回值：True----已经安装
'False----没有安装
'**************************************************
FunctionIsObjInstalled(strClassString)
OnErrorResumeNext
IsObjInstalled=False
Err=0
DimxTestObj
SetxTestObj=Server.CreateObject(strClassString)
If0=ErrThenIsObjInstalled=True
SetxTestObj=Nothing
Err=0
EndFunction
'**************************************************
'过程名：WriteErrMsg
'作用：显示错误提示信息
'参数：无
'**************************************************
subWriteErrMsg(ErrMsg)
dimstrErr
strErr=strErr&"<html><head><title>错误信息</title><metahttp-equiv='Content-Type'content='text/html;charset=gb2312'>"&vbcrlf
strErr=strErr&"<linkhref='../admin/Admin_STYLE.CSS'rel='stylesheet'type='text/css'></head><body><br><br>"&vbcrlf
strErr=strErr&"<tablecellpadding=2cellspacing=1border=0width=400class='border'align=center>"&vbcrlf
strErr=strErr&"<tralign='center'class='title'><tdheight='22'><strong>错误信息</strong></td></tr>"&vbcrlf
strErr=strErr&"<trclass='tdbg'><tdheight='100'valign='top'><b>产生错误的可能原因：</b>"&ErrMsg&"</td></tr>"&vbcrlf
strErr=strErr&"<tralign='center'class='tdbg'><td><ahref='javascript:history.go(-1)'><<返回上一页</a></td></tr>"&vbcrlf
strErr=strErr&"</table>"&vbcrlf
strErr=strErr&"</body></html>"&vbcrlf
response.writestrErr
endsub
'**************************************************
'过程名：WriteSucced
'作用：显示成功提示信息
'参数：无
'**************************************************
subWriteSucced(ErrMsg)
dimstrErr
strErr=strErr&"<html><head><title>成功信息</title><metahttp-equiv='Content-Type'content='text/html;charset=gb2312'>"&vbcrlf
strErr=strErr&"<linkhref='../admin/Admin_STYLE.CSS'rel='stylesheet'type='text/css'></head><body><br><br>"&vbcrlf
strErr=strErr&"<tablecellpadding=2cellspacing=1border=0width=400class='border'align=center>"&vbcrlf
strErr=strErr&"<tralign='center'class='title'><tdheight='22'><strong>恭喜你！</strong></td></tr>"&vbcrlf
strErr=strErr&"<trclass='tdbg'><tdheight='100'valign='top'align='center'>"&ErrMsg&"</td></tr>"&vbcrlf
'strErr=strErr&"<tralign='center'class='tdbg'><td><ahref='javascript:history.go(-1)'><<返回上一页</a></td></tr>"&vbcrlf
strErr=strErr&"</table>"&vbcrlf
strErr=strErr&"</body></html>"&vbcrlf
response.writestrErr
endsub
'**************************************************
'函数名：ShowPage
'作用：显示“上一页下一页”等信息
'参数：sFileName----链接地址
'TotalNumber----总数量
'MaxPerPage----每页数量
'ShowTotal----是否显示总数量
'ShowAllPages---是否用下拉列表显示所有页面以供跳转。有某些页面不能使用，否则会出现JS错误。
'strUnit----计数单位
'返回值：“上一页下一页”等信息的HTML代码
'**************************************************
functionShowPage(sFileName,TotalNumber,MaxPerPage,ShowTotal,ShowAllPages,strUnit)
dimTotalPage,strTemp,strUrl,i
ifTotalNumber=0orMaxPerPage=0orisNull(MaxPerPage)then
ShowPage=""
exitfunction
endif
iftotalnumbermodmaxperpage=0then
TotalPage=totalnumber\maxperpage
else
TotalPage=totalnumber\maxperpage+1
endif
ifCurrentPage>TotalPagethenCurrentPage=TotalPage
strTemp="<tablealign='center'><tr><td>"
ifShowTotal=truethen
strTemp=strTemp&"共<b>"&totalnumber&"</b>"&strUnit&""
endif
strUrl=JoinChar(sfilename)
ifCurrentPage<2then
strTemp=strTemp&"首页上一页"
else
strTemp=strTemp&"<ahref='"&strUrl&"page=1'>首页</a>"
strTemp=strTemp&"<ahref='"&strUrl&"page="&(CurrentPage-1)&"'>上一页</a>"
endif
ifCurrentPage>=TotalPagethen
strTemp=strTemp&"下一页尾页"
else
strTemp=strTemp&"<ahref='"&strUrl&"page="&(CurrentPage+1)&"'>下一页</a>"
strTemp=strTemp&"<ahref='"&strUrl&"page="&TotalPage&"'>尾页</a>"
endif
strTemp=strTemp&"页次：<strong><fontcolor=red>"&CurrentPage&"</font>/"&TotalPage&"</strong>页"
strTemp=strTemp&"<b>"&maxperpage&"</b>"&strUnit&"/页"
ifShowAllPages=Truethen
strTemp=strTemp&"转到第<inputtype='text'name='page'size='3'maxlength='5'value='"&CurrentPage&"'onKeyPress=""if(event.keyCode==13)window.location='"&strUrl&"page="&"'+this.value;""'>页"
endif
strTemp=strTemp&"</td></tr></table>"
ShowPage=strTemp
endfunction
'**************************************************
'函数名：JoinChar
'作用：向地址中加入?或&
'参数：strUrl----网址
'返回值：加了?或&的网址
'**************************************************
functionJoinChar(strUrl)
ifstrUrl=""then
JoinChar=""
exitfunction
endif
ifInStr(strUrl,"?")<len(strUrl)then
ifInStr(strUrl,"?")>1then
ifInStr(strUrl,"&")<len(strUrl)then
JoinChar=strUrl&"&"
else
JoinChar=strUrl
endif
else
JoinChar=strUrl&"?"
endif
else
JoinChar=strUrl
endif
endfunction
'**************************************************
'函数名：CreateKeyWord
'作用：由给定的字符串生成关键字
'参数：Constr---要生成关键字的原字符串
'返回值：生成的关键字
'**************************************************
FunctionCreateKeyWord(byvalConstr)
IfConstr=""orIsNull(Constr)=TrueorConstr="$False$"Then
CreateKeyWord="$False$"
ExitFunction
EndIf
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,">","")
Dimi,ConstrTemp
Fori=1ToLen(Constr)
ConstrTemp=ConstrTemp&"|"&Mid(Constr,i,2)
Next
IfLen(ConstrTemp)<254Then
ConstrTemp=ConstrTemp&"|"
Else
ConstrTemp=Left(ConstrTemp,254)&"|"
EndIf
CreateKeyWord=ConstrTemp
EndFunction
FunctionCheckUrl(strUrl)
DimRe
SetRe=newRegExp
Re.IgnoreCase=true
Re.Global=True
Re.Pattern=" http://([\w-]+\.)+[\w-]+(/[\w-./?%&=]*)?"
IfRe.test(strUrl)=TrueThen
CheckUrl=strUrl
Else
CheckUrl="$False$"
EndIf
SetRs=Nothing
EndFunction
%>
其中的html代码处理函数很管用，写得相当漂亮
<%
'==================================================
'函数名：GetHttpPage
'作用：获取网页源码
'参数：HttpUrl------网页地址
'==================================================
FunctionGetHttpPage(HttpUrl)
IfIsNull(HttpUrl)=TrueorLen(HttpUrl)<18orHttpUrl="$False$"Then
GetHttpPage="$False$"
ExitFunction
EndIf
DimHttp
SetHttp=server.createobject("MSXML2.XMLHTTP")
Http.open"GET",HttpUrl,False
Http.Send()
IfHttp.Readystate<>4then
SetHttp=Nothing
GetHttpPage="$False$"
Exitfunction
Endif
GetHTTPPage=bytesToBSTR(Http.responseBody,"GB2312")
SetHttp=Nothing
IfErr.number<>0then
Err.Clear
EndIf
EndFunction
'==================================================
'函数名：BytesToBstr
'作用：将获取的源码转换为中文
'参数：Body------要转换的变量
'参数：Cset------要转换的类型
'==================================================
FunctionBytesToBstr(Body,Cset)
DimObjstream
SetObjstream=Server.CreateObject("adodb.stream")
objstream.Type=1
objstream.Mode=3
objstream.Open
objstream.Writebody
objstream.Position=0
objstream.Type=2
objstream.Charset=Cset
BytesToBstr=objstream.ReadText
objstream.Close
setobjstream=nothing
EndFunction
'==================================================
'函数名：PostHttpPage
'作用：登录
'==================================================
FunctionPostHttpPage(RefererUrl,PostUrl,PostData)
DimxmlHttp
DimRetStr
SetxmlHttp=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.SendPostData
IfErr.Number<>0Then
SetxmlHttp=Nothing
PostHttpPage="$False$"
ExitFunction
EndIf
PostHttpPage=bytesToBSTR(xmlHttp.responseBody,"GB2312")
SetxmlHttp=nothing
EndFunction
'==================================================
'函数名：UrlEncoding
'作用：转换编码
'==================================================
FunctionUrlEncoding(DataStr)
DimStrReturn,Si,ThisChr,InnerCode,Hight8,Low8
StrReturn=""
ForSi=1ToLen(DataStr)
ThisChr=Mid(DataStr,Si,1)
IfAbs(Asc(ThisChr))<&HFFThen
StrReturn=StrReturn&ThisChr
Else
InnerCode=Asc(ThisChr)
IfInnerCode<0Then
InnerCode=InnerCode+&H10000
EndIf
Hight8=(InnerCodeAnd&HFF00)\&HFF
Low8=InnerCodeAnd&HFF
StrReturn=StrReturn&"%"&Hex(Hight8)&"%"&Hex(Low8)
EndIf
Next
UrlEncoding=StrReturn
EndFunction
'==================================================
'函数名：GetBody
'作用：截取字符串
'参数：ConStr------将要截取的字符串
'参数：StartStr------开始字符串
'参数：OverStr------结束字符串
'参数：IncluL------是否包含StartStr
'参数：IncluR------是否包含OverStr
'==================================================
FunctionGetBody(ConStr,StartStr,OverStr,IncluL,IncluR)
IfConStr="$False$"orConStr=""orIsNull(ConStr)=TrueorStartStr=""orIsNull(StartStr)=TrueorOverStr=""orIsNull(OverStr)=TrueThen
GetBody="$False$"
ExitFunction
EndIf
DimConStrTemp
DimStart,Over
ConStrTemp=Lcase(ConStr)
StartStr=Lcase(StartStr)
OverStr=Lcase(OverStr)
Start=InStrB(1,ConStrTemp,StartStr,vbBinaryCompare)
IfStart<=0then
GetBody="$False$"
ExitFunction
Else
IfIncluL=FalseThen
Start=Start+LenB(StartStr)
EndIf
EndIf
Over=InStrB(Start,ConStrTemp,OverStr,vbBinaryCompare)
IfOver<=0orOver<=Startthen
GetBody="$False$"
ExitFunction
Else
IfIncluR=TrueThen
Over=Over+LenB(OverStr)
EndIf
EndIf
GetBody=MidB(ConStr,Start,Over-Start)
EndFunction
'==================================================
'函数名：GetArray
'作用：提取链接地址，以$Array$分隔
'参数：ConStr------提取地址的原字符
'参数：StartStr------开始字符串
'参数：OverStr------结束字符串
'参数：IncluL------是否包含StartStr
'参数：IncluR------是否包含OverStr
'==================================================
FunctionGetArray(ByvalConStr,StartStr,OverStr,IncluL,IncluR)
IfConStr="$False$"orConStr=""orIsNull(ConStr)=TrueorStartStr=""orOverStr=""orIsNull(StartStr)=TrueorIsNull(OverStr)=TrueThen
GetArray="$False$"
ExitFunction
EndIf
DimTempStr,TempStr2,objRegExp,Matches,Match
TempStr=""
SetobjRegExp=NewRegexp
objRegExp.IgnoreCase=True
objRegExp.Global=True
objRegExp.Pattern="("&StartStr&").+?("&OverStr&")"
SetMatches=objRegExp.Execute(ConStr)
ForEachMatchinMatches
TempStr=TempStr&"$Array$"&Match.Value
Next
SetMatches=nothing
IfTempStr=""Then
GetArray="$False$"
ExitFunction
EndIf
TempStr=Right(TempStr,Len(TempStr)-7)
IfIncluL=Falsethen
objRegExp.Pattern=StartStr
TempStr=objRegExp.Replace(TempStr,"")
Endif
IfIncluR=Falsethen
objRegExp.Pattern=OverStr
TempStr=objRegExp.Replace(TempStr,"")
Endif
SetobjRegExp=nothing
TempStr=Replace(TempStr,"""","")
TempStr=Replace(TempStr,"'","")
TempStr=Replace(TempStr,"","")
IfTempStr=""then
GetArray="$False$"
Else
GetArray=TempStr
Endif
EndFunction
'==================================================
'函数名：DefiniteUrl
'作用：将相对地址转换为绝对地址
'参数：PrimitiveUrl------要转换的相对地址
'参数：ConsultUrl------当前网页地址
'==================================================
FunctionDefiniteUrl(ByvalPrimitiveUrl,ByvalConsultUrl)
DimConTemp,PriTemp,Pi,Ci,PriArray,ConArray
IfPrimitiveUrl=""orConsultUrl=""orPrimitiveUrl="$False$"orConsultUrl="$False$"Then
DefiniteUrl="$False$"
ExitFunction
EndIf
IfLeft(Lcase(ConsultUrl),7)<>" http://"Then
ConsultUrl=" http://"&ConsultUrl
EndIf
ConsultUrl=Replace(ConsultUrl,"\","/")
ConsultUrl=Replace(ConsultUrl,"://",":\\")
PrimitiveUrl=Replace(PrimitiveUrl,"\","/")
IfRight(ConsultUrl,1)<>"/"Then
IfInstr(ConsultUrl,"/")>0Then
IfInstr(Right(ConsultUrl,Len(ConsultUrl)-InstrRev(ConsultUrl,"/")),".")>0then
Else
ConsultUrl=ConsultUrl&"/"
EndIf
Else
ConsultUrl=ConsultUrl&"/"
EndIf
EndIf
ConArray=Split(ConsultUrl,"/")
IfLeft(LCase(PrimitiveUrl),7)=" http://"then
DefiniteUrl=Replace(PrimitiveUrl,"://",":\\")
ElseIfLeft(PrimitiveUrl,1)="/"Then
DefiniteUrl=ConArray(0)&PrimitiveUrl
ElseIfLeft(PrimitiveUrl,2)="./"Then
PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-2)
IfRight(ConsultUrl,1)="/"Then
DefiniteUrl=ConsultUrl&PrimitiveUrl
Else
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/"))&PrimitiveUrl
EndIf
ElseIfLeft(PrimitiveUrl,3)="../"then
DoWhileLeft(PrimitiveUrl,3)="../"
PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-3)
Pi=Pi+1
Loop
ForCi=0to(Ubound(ConArray)-1-Pi)
IfDefiniteUrl<>""Then
DefiniteUrl=DefiniteUrl&"/"&ConArray(Ci)
Else
DefiniteUrl=ConArray(Ci)
EndIf
Next
DefiniteUrl=DefiniteUrl&"/"&PrimitiveUrl
Else
IfInstr(PrimitiveUrl,"/")>0Then
PriArray=Split(PrimitiveUrl,"/")
IfInstr(PriArray(0),".")>0Then
IfRight(PrimitiveUrl,1)="/"Then
DefiniteUrl="http:\\"&PrimitiveUrl
Else
IfInstr(PriArray(Ubound(PriArray)-1),".")>0Then
DefiniteUrl="http:\\"&PrimitiveUrl
Else
DefiniteUrl="http:\\"&PrimitiveUrl&"/"
EndIf
EndIf
Else
IfRight(ConsultUrl,1)="/"Then
DefiniteUrl=ConsultUrl&PrimitiveUrl
Else
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/"))&PrimitiveUrl
EndIf
EndIf
Else
IfInstr(PrimitiveUrl,".")>0Then
IfRight(ConsultUrl,1)="/"Then
Ifright(LCase(PrimitiveUrl),3)=".cn"orright(LCase(PrimitiveUrl),3)="com"orright(LCase(PrimitiveUrl),3)="net"orright(LCase(PrimitiveUrl),3)="org"Then
DefiniteUrl="http:\\"&PrimitiveUrl&"/"
Else
DefiniteUrl=ConsultUrl&PrimitiveUrl
EndIf
Else
Ifright(LCase(PrimitiveUrl),3)=".cn"orright(LCase(PrimitiveUrl),3)="com"orright(LCase(PrimitiveUrl),3)="net"orright(LCase(PrimitiveUrl),3)="org"Then
DefiniteUrl="http:\\"&PrimitiveUrl&"/"
Else
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/"))&"/"&PrimitiveUrl
EndIf
EndIf
Else
IfRight(ConsultUrl,1)="/"Then
DefiniteUrl=ConsultUrl&PrimitiveUrl&"/"
Else
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/"))&"/"&PrimitiveUrl&"/"
EndIf
EndIf
EndIf
EndIf
IfLeft(DefiniteUrl,1)="/"then
DefiniteUrl=Right(DefiniteUrl,Len(DefiniteUrl)-1)
Endif
IfDefiniteUrl<>""Then
DefiniteUrl=Replace(DefiniteUrl,"//","/")
DefiniteUrl=Replace(DefiniteUrl,":\\","://")
Else
DefiniteUrl="$False$"
EndIf
EndFunction
'==================================================
'函数名：ReplaceSaveRemoteFile
'作用：替换、保存远程图片
'参数：ConStr------要替换的字符串
'参数：SaveTf------是否保存文件，False不保存，True保存
'参数:TistUrl------当前网页地址
'==================================================
FunctionReplaceSaveRemoteFile(ConStr,strInstallDir,strChannelDir,SaveTf,TistUrl)
IfConStr="$False$"orConStr=""orstrInstallDir=""orstrChannelDir=""Then
ReplaceSaveRemoteFile=ConStr
ExitFunction
EndIf
DimTempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2
DimStart1,Start2
SetRe=NewRegexp
Re.IgnoreCase=True
Re.Global=True
Re.Pattern="<img.+?[^\>]>"
SetMatches=Re.Execute(ConStr)
ForEachMatchinMatches
IfTempStr<>""then
TempStr=TempStr&"$Array$"&Match.Value
Else
TempStr=Match.Value
Endif
Next
IfTempStr<>""Then
TempArray=Split(TempStr,"$Array$")
TempStr=""
ForTempi=0ToUbound(TempArray)
Re.Pattern="src\s*=\s*.+?\.(gif|jpg|bmp|jpeg|psd|png|svg|dxf|wmf|tiff)"
SetMatches=Re.Execute(TempArray(Tempi))
ForEachMatchinMatches
IfTempStr<>""then
TempStr=TempStr&"$Array$"&Match.Value
Else
TempStr=Match.Value
Endif
Next
Next
Endif
IfTempStr<>""Then
Re.Pattern="src\s*=\s*"
TempStr=Re.Replace(TempStr,"")
EndIf
SetMatches=nothing
SetRe=nothing
IfTempStr=""orIsNull(TempStr)=TrueThen
ReplaceSaveRemoteFile=ConStr
Exitfunction
Endif
TempStr=Replace(TempStr,"""","")
TempStr=Replace(TempStr,"'","")
TempStr=Replace(TempStr,"","")
DimRemoteFileurl,SavePath,PathTemp,DtNow,strFileName,strFileType,ArrSaveFileName,RanNum,Arr_Path
DtNow=Now()
IfSaveTf=Truethen
SavePath=strInstallDir&strChannelDir&"/UploadFiles/"&year(DtNow)&right("0"&month(DtNow),2)&"/"
Arr_Path=Split(SavePath,"/")
PathTemp=""
ForTempi=0ToUbound(Arr_Path)
IfTempi=0Then
PathTemp=Arr_Path(0)&"/"
ElseIfTempi=Ubound(Arr_Path)Then
ExitFor
Else
PathTemp=PathTemp&Arr_Path(Tempi)&"/"
EndIf
IfCheckDir(PathTemp)=FalseThen
IfMakeNewsDir(PathTemp)=FalseThen
SaveTf=False
ExitFor
EndIf
EndIf
Next
EndIf
'去掉重复图片开始
TempArray=Split(TempStr,"$Array$")
TempStr=""
ForTempi=0ToUbound(TempArray)
IfInstr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1Then
TempStr=TempStr&"$Array$"&TempArray(Tempi)
EndIf
Next
TempStr=Right(TempStr,Len(TempStr)-7)
TempArray=Split(TempStr,"$Array$")
'去掉重复图片结束
'转换相对图片地址开始
TempStr=""
ForTempi=0ToUbound(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=""
'转换相对图片地址结束
'图片替换/保存
SetRe=NewRegexp
Re.IgnoreCase=True
Re.Global=True
ForTempi=0ToUbound(TempArray2)
RemoteFileUrl=TempArray2(Tempi)
IfRemoteFileUrl<>"$False$"AndSaveTf=TrueThen'保存图片
ArrSaveFileName=Split(RemoteFileurl,".")
strFileType=Lcase(ArrSaveFileName(Ubound(ArrSaveFileName)))'文件类型
IfstrFileType="asp"orstrFileType="asa"orstrFileType="aspx"orstrFileType="cer"orstrFileType="cdx"orstrFileType="exe"orstrFileType="rar"orstrFileType="zip"then
UploadFiles=""
ReplaceSaveRemoteFile=ConStr
ExitFunction
EndIf
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)
IfSaveRemoteFile(SavePath&strFileName,RemoteFileUrl)=TrueThen
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
EndIf
ElseIfRemoteFileurl<>"$False$"andSaveTf=FalseThen'不保存图片
Re.Pattern=TempArray(Tempi)
ConStr=Re.Replace(ConStr,RemoteFileUrl)
UploadFiles=UploadFiles&"|"&RemoteFileUrl
EndIf
Next
SetRe=nothing
IfUploadFiles<>""Then
UploadFiles=Right(UploadFiles,Len(UploadFiles)-1)
EndIf
ReplaceSaveRemoteFile=ConStr
Endfunction
'==================================================
'过程名：SaveRemoteFile
'作用：保存远程的文件到本地
'参数：LocalFileName------本地文件名
'参数：RemoteFileUrl------远程文件URL
'==================================================
FunctionSaveRemoteFile(LocalFileName,RemoteFileUrl)
Onerrorresumenext
SaveRemoteFile=True
dimAds,Retrieval,GetRemoteData
SetRetrieval=Server.CreateObject("Microsoft.XMLHTTP")
WithRetrieval
.Open"Get",RemoteFileUrl,False,"",""
.Send
If.Readystate<>4then
SaveRemoteFile=False
ExitFunction
EndIf
GetRemoteData=.ResponseBody
EndWith
SetRetrieval=Nothing
SetAds=Server.CreateObject("Adodb.Stream")
WithAds
.Type=1
.Open
.WriteGetRemoteData
.SaveToFileserver.MapPath(LocalFileName),2
.Cancel()
.Close()
EndWith
SetAds=nothing
endFunction
'==================================================
'函数名：FpHtmlEnCode
'作用：标题过滤
'参数：fString------字符串
'==================================================
FunctionFpHtmlEnCode(fString)
IfIsNull(fString)=FalseorfString<>""orfString<>"$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$"
EndIf
EndFunction
'==================================================
'函数名：GetPaing
'作用：获取分页
'==================================================
FunctionGetPaing(ByvalConStr,StartStr,OverStr,IncluL,IncluR)
IfConStr="$False$"orConStr=""orStartStr=""orOverStr=""orIsNull(ConStr)=TrueorIsNull(StartStr)=TrueorIsNull(OverStr)=TrueThen
GetPaing="$False$"
ExitFunction
EndIf
DimStart,Over,ConTemp,Erri
ConStr=LCase(ConStr)
StartStr=LCase(StartStr)
OverStr=LCase(OverStr)
Over=InstrB(1,ConStr,OverStr,vbBinaryCompare)
IfOver<=0Then
GetPaing="$False$"
ExitFunction
Else
Over=Over+Lenb(OverStr)
EndIf
Start=Over-5
IfStart<=0Then
GetPaing="$False$"
ExitFunction
EndIf
ConTemp=MidB(ConStr,Start,Over-Start)
DoWhileInstrB(1,ConTemp,StartStr,vbBinaryCompare)<=0
Erri=Erri+1
IfErri>50then
GetPaing="$False$"
ExitFunction
EndIf
Start=Start-5
ifStart<=0then
GetPaing="$False$"
ExitDo
ExitFunction
Else
ConTemp=MidB(ConStr,Start,Over-Start)
EndIf
Loop
Start=InstrB(1,ConTemp,StartStr,vbBinaryCompare)
IfIncluL=FalseThen
Start=Start+LenB(StartStr)
EndIf
Over=InstrB(Start,ConTemp,OverStr,vbBinaryCompare)
IfIncluR=TrueThen
Over=Over+LenB(OverStr)
EndIf
IfStart>=Overthen
GetPaing="$False$"
ExitFunction
EndIf
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,"<","")
EndFunction
'==================================================
'函数名：ScriptHtml
'作用：过滤html标记
'参数：ConStr------要过滤的字符串
'==================================================
FunctionScriptHtml(ByvalConStr,TagName,FType)
DimRe
SetRe=newRegExp
Re.IgnoreCase=true
Re.Global=True
SelectCaseFType
Case1
Re.Pattern="<"&TagName&"([^>])*>"
ConStr=Re.Replace(ConStr,"")
Case2
Re.Pattern="<"&TagName&"([^>])*>.*?</"&TagName&"([^>])*>"
ConStr=Re.Replace(ConStr,"")
Case3
Re.Pattern="<"&TagName&"([^>])*>"
ConStr=Re.Replace(ConStr,"")
Re.Pattern="</"&TagName&"([^>])*>"
ConStr=Re.Replace(ConStr,"")
EndSelect
ScriptHtml=ConStr
SetRe=Nothing
EndFunction
FunctionCheckDir(byvalFolderPath)
dimfso
Setfso=Server.CreateObject("Scripting.FileSystemObject")
Iffso.FolderExists(Server.MapPath(folderpath))then
'存在
CheckDir=True
Else
'不存在
CheckDir=False
Endif
Setfso=nothing
EndFunction
FunctionMakeNewsDir(byvalfoldername)
dimfso
Setfso=Server.CreateObject("Scripting.FileSystemObject")
fso.CreateFolder(Server.MapPath(foldername))
Iffso.FolderExists(Server.MapPath(foldername))Then
MakeNewsDir=True
Else
MakeNewsDir=False
EndIf
Setfso=nothing
EndFunction
'**************************************************
'函数名：IsObjInstalled
'作用：检查组件是否已经安装
'参数：strClassString----组件名
'返回值：True----已经安装
'False----没有安装
'**************************************************
FunctionIsObjInstalled(strClassString)
OnErrorResumeNext
IsObjInstalled=False
Err=0
DimxTestObj
SetxTestObj=Server.CreateObject(strClassString)
If0=ErrThenIsObjInstalled=True
SetxTestObj=Nothing
Err=0
EndFunction
'**************************************************
'过程名：WriteErrMsg
'作用：显示错误提示信息
'参数：无
'**************************************************
subWriteErrMsg(ErrMsg)
dimstrErr
strErr=strErr&"<html><head><title>错误信息</title><metahttp-equiv='Content-Type'content='text/html;charset=gb2312'>"&vbcrlf
strErr=strErr&"<linkhref='../admin/Admin_STYLE.CSS'rel='stylesheet'type='text/css'></head><body><br><br>"&vbcrlf
strErr=strErr&"<tablecellpadding=2cellspacing=1border=0width=400class='border'align=center>"&vbcrlf
strErr=strErr&"<tralign='center'class='title'><tdheight='22'><strong>错误信息</strong></td></tr>"&vbcrlf
strErr=strErr&"<trclass='tdbg'><tdheight='100'valign='top'><b>产生错误的可能原因：</b>"&ErrMsg&"</td></tr>"&vbcrlf
strErr=strErr&"<tralign='center'class='tdbg'><td><ahref='javascript:history.go(-1)'><<返回上一页</a></td></tr>"&vbcrlf
strErr=strErr&"</table>"&vbcrlf
strErr=strErr&"</body></html>"&vbcrlf
response.writestrErr
endsub
'**************************************************
'过程名：WriteSucced
'作用：显示成功提示信息
'参数：无
'**************************************************
subWriteSucced(ErrMsg)
dimstrErr
strErr=strErr&"<html><head><title>成功信息</title><metahttp-equiv='Content-Type'content='text/html;charset=gb2312'>"&vbcrlf
strErr=strErr&"<linkhref='../admin/Admin_STYLE.CSS'rel='stylesheet'type='text/css'></head><body><br><br>"&vbcrlf
strErr=strErr&"<tablecellpadding=2cellspacing=1border=0width=400class='border'align=center>"&vbcrlf
strErr=strErr&"<tralign='center'class='title'><tdheight='22'><strong>恭喜你！</strong></td></tr>"&vbcrlf
strErr=strErr&"<trclass='tdbg'><tdheight='100'valign='top'align='center'>"&ErrMsg&"</td></tr>"&vbcrlf
'strErr=strErr&"<tralign='center'class='tdbg'><td><ahref='javascript:history.go(-1)'><<返回上一页</a></td></tr>"&vbcrlf
strErr=strErr&"</table>"&vbcrlf
strErr=strErr&"</body></html>"&vbcrlf
response.writestrErr
endsub
'**************************************************
'函数名：ShowPage
'作用：显示“上一页下一页”等信息
'参数：sFileName----链接地址
'TotalNumber----总数量
'MaxPerPage----每页数量
'ShowTotal----是否显示总数量
'ShowAllPages---是否用下拉列表显示所有页面以供跳转。有某些页面不能使用，否则会出现JS错误。
'strUnit----计数单位
'返回值：“上一页下一页”等信息的HTML代码
'**************************************************
functionShowPage(sFileName,TotalNumber,MaxPerPage,ShowTotal,ShowAllPages,strUnit)
dimTotalPage,strTemp,strUrl,i
ifTotalNumber=0orMaxPerPage=0orisNull(MaxPerPage)then
ShowPage=""
exitfunction
endif
iftotalnumbermodmaxperpage=0then
TotalPage=totalnumber\maxperpage
else
TotalPage=totalnumber\maxperpage+1
endif
ifCurrentPage>TotalPagethenCurrentPage=TotalPage
strTemp="<tablealign='center'><tr><td>"
ifShowTotal=truethen
strTemp=strTemp&"共<b>"&totalnumber&"</b>"&strUnit&""
endif
strUrl=JoinChar(sfilename)
ifCurrentPage<2then
strTemp=strTemp&"首页上一页"
else
strTemp=strTemp&"<ahref='"&strUrl&"page=1'>首页</a>"
strTemp=strTemp&"<ahref='"&strUrl&"page="&(CurrentPage-1)&"'>上一页</a>"
endif
ifCurrentPage>=TotalPagethen
strTemp=strTemp&"下一页尾页"
else
strTemp=strTemp&"<ahref='"&strUrl&"page="&(CurrentPage+1)&"'>下一页</a>"
strTemp=strTemp&"<ahref='"&strUrl&"page="&TotalPage&"'>尾页</a>"
endif
strTemp=strTemp&"页次：<strong><fontcolor=red>"&CurrentPage&"</font>/"&TotalPage&"</strong>页"
strTemp=strTemp&"<b>"&maxperpage&"</b>"&strUnit&"/页"
ifShowAllPages=Truethen
strTemp=strTemp&"转到第<inputtype='text'name='page'size='3'maxlength='5'value='"&CurrentPage&"'onKeyPress=""if(event.keyCode==13)window.location='"&strUrl&"page="&"'+this.value;""'>页"
endif
strTemp=strTemp&"</td></tr></table>"
ShowPage=strTemp
endfunction
'**************************************************
'函数名：JoinChar
'作用：向地址中加入?或&
'参数：strUrl----网址
'返回值：加了?或&的网址
'**************************************************
functionJoinChar(strUrl)
ifstrUrl=""then
JoinChar=""
exitfunction
endif
ifInStr(strUrl,"?")<len(strUrl)then
ifInStr(strUrl,"?")>1then
ifInStr(strUrl,"&")<len(strUrl)then
JoinChar=strUrl&"&"
else
JoinChar=strUrl
endif
else
JoinChar=strUrl&"?"
endif
else
JoinChar=strUrl
endif
endfunction
'**************************************************
'函数名：CreateKeyWord
'作用：由给定的字符串生成关键字
'参数：Constr---要生成关键字的原字符串
'返回值：生成的关键字
'**************************************************
FunctionCreateKeyWord(byvalConstr)
IfConstr=""orIsNull(Constr)=TrueorConstr="$False$"Then
CreateKeyWord="$False$"
ExitFunction
EndIf
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,">","")
Dimi,ConstrTemp
Fori=1ToLen(Constr)
ConstrTemp=ConstrTemp&"|"&Mid(Constr,i,2)
Next
IfLen(ConstrTemp)<254Then
ConstrTemp=ConstrTemp&"|"
Else
ConstrTemp=Left(ConstrTemp,254)&"|"
EndIf
CreateKeyWord=ConstrTemp
EndFunction
FunctionCheckUrl(strUrl)
DimRe
SetRe=newRegExp
Re.IgnoreCase=true
Re.Global=True
Re.Pattern=" http://([\w-]+\.)+[\w-]+(/[\w-./?%&=]*)?"
IfRe.test(strUrl)=TrueThen
CheckUrl=strUrl
Else
CheckUrl="$False$"
EndIf
SetRs=Nothing
EndFunction
%>