'=================================================='函数名：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 IfEnd 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 = nothingEnd 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 = StrReturnEnd Function
'=================================================='过程名：SaveRemoteFile'作 用：保存远程的文件到本地'参 数：LocalFileName ------ 本地文件名'参 数：RemoteFileUrl ------ 远程文件URL'==================================================Function SaveRemoteFile(LocalFileName,RemoteFileUrl) SaveRemoteFile=Truedim Ads,Retrieval,GetRemoteDataSet Retrieval = Server.CreateObject("Microsoft.XMLHTTP")With Retrieval.Open "Get", RemoteFileUrl, False, "", "".Send If .Readystate<>4 then SaveRemoteFile=False Exit Function End IfGetRemoteData = .ResponseBodyEnd WithSet Retrieval = NothingSet Ads = Server.CreateObject("Adodb.Stream")With Ads.Type = 1.Open.Write GetRemoteData.SaveToFile server.MapPath(LocalFileName),2.Cancel().Close()End WithSet Ads=nothingend 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=NothingEnd Function
'**************************************************'函数名：IsObjInstalled'作 用：检查组件是否已经安装'参 数：strClassString ----组件名'返回值：True ----已经安装' False ----没有安装'**************************************************Function IsObjInstalled(strClassString)IsObjInstalled = FalseErr = 0Dim xTestObjSet xTestObj = Server.CreateObject(strClassString)If 0 = Err Then IsObjInstalled = TrueSet xTestObj = NothingErr = 0End Function
