asp採集程式類

'=================================================='函數名：GetHttpPage'作 用：擷取網頁源碼'參 數：HttpUrl ——網頁地址'==================================================Function GetHttpPage(HttpUrl)If IsNull(HttpUrl)=True Or Len(HttpUrl)<18 Or HttpUrl="$False$" ThenGetHttpPage="$False$"Exit FunctionEnd IfDim HttpSet Http=server.createobject("MSXML2.XMLHTTP")Http.open "GET",HttpUrl,FalseHttp.Send()If Http.Readystate<>4 thenSet Http=NothingGetHttpPage="$False$"Exit functionEnd ifGetHTTPPage=bytesToBSTR(Http.responseBody,"GB2312")Set Http=NothingIf Err.number<>0 thenErr.ClearEnd IfEnd Function'=================================================='函數名：BytesToBstr'作 用：將擷取的源碼轉換為中文'參 數：Body ——要轉換的變數'參 數：Cset ——要轉換的類型'==================================================Function BytesToBstr(Body,Cset)Dim ObjstreamSet Objstream = Server.CreateObject("adodb.stream")objstream.Type = 1objstream.Mode =3objstream.Openobjstream.Write bodyobjstream.Position = 0objstream.Type = 2objstream.Charset = CsetBytesToBstr = objstream.ReadTextobjstream.Closeset objstream = nothingEnd Function'=================================================='函數名：UrlEncoding'作 用：轉換編碼'==================================================Function UrlEncoding(DataStr)Dim StrReturn,Si,ThisChr,InnerCode,Hight8,Low8StrReturn = ""For Si = 1 To Len(DataStr)ThisChr = Mid(DataStr,Si,1)If Abs(Asc(ThisChr)) < &HFF ThenStrReturn = StrReturn & ThisChrElseInnerCode = Asc(ThisChr)If InnerCode < 0 ThenInnerCode = InnerCode + &H10000End IfHight8 = (InnerCode And &HFF00)\ &HFFLow8 = InnerCode And &HFFStrReturn = StrReturn & "%" & Hex(Hight8) & "%" & Hex(Low8)End IfNextUrlEncoding = StrReturnEnd 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 ThenGetBody="$False$"Exit FunctionEnd IfDim ConStrTempDim Start,OverConStrTemp=Lcase(ConStr)StartStr=Lcase(StartStr)OverStr=Lcase(OverStr)Start = InStrB(1, ConStrTemp, StartStr, vbBinaryCompare)If Start<=0 thenGetBody="$False$"Exit FunctionElseIf IncluL=False ThenStart=Start+LenB(StartStr)End IfEnd IfOver=InStrB(Start,ConStrTemp,OverStr,vbBinaryCompare)If Over<=0 Or Over<=Start thenGetBody="$False$"Exit FunctionElseIf IncluR=True ThenOver=Over+LenB(OverStr)End IfEnd IfGetBody=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 ThenGetArray="$False$"Exit FunctionEnd IfDim TempStr,TempStr2,objRegExp,Matches,MatchTempStr=""Set objRegExp = New RegexpobjRegExp.IgnoreCase = TrueobjRegExp.Global = TrueobjRegExp.Pattern = "("&StartStr&").+?("&OverStr&")"Set Matches =objRegExp.Execute(ConStr)For Each Match in MatchesTempStr=TempStr & "$Array$" & Match.ValueNextSet Matches=nothingIf TempStr="" ThenGetArray="$False$"Exit FunctionEnd IfTempStr=Right(TempStr,Len(TempStr)-7)If IncluL=False thenobjRegExp.Pattern =StartStrTempStr=objRegExp.Replace(TempStr,"")End ifIf IncluR=False thenobjRegExp.Pattern =OverStrTempStr=objRegExp.Replace(TempStr,"")End ifSet objRegExp=nothingSet Matches=nothingTempStr=Replace(TempStr,"""","")TempStr=Replace(TempStr,"'","")TempStr=Replace(TempStr," ","")TempStr=Replace(TempStr,"(","")TempStr=Replace(TempStr,")","")If TempStr="" thenGetArray="$False$"ElseGetArray=TempStrEnd ifEnd Function'=================================================='函數名：DefiniteUrl'作 用：將相對位址轉換為絕對位址'參 數：PrimitiveUrl ------要轉換的相對位址'參 數：ConsultUrl ------當前網頁地址'==================================================Function DefiniteUrl(Byval PrimitiveUrl,Byval ConsultUrl)Dim ConTemp,PriTemp,Pi,Ci,PriArray,ConArrayIf PrimitiveUrl="" or ConsultUrl="" or PrimitiveUrl="$False$" or ConsultUrl="$False$" ThenDefiniteUrl="$False$"Exit FunctionEnd IfIf Left(Lcase(ConsultUrl),7)<>"http://" ThenConsultUrl= "http://" & ConsultUrlEnd IfConsultUrl=Replace(ConsultUrl,"\","/")ConsultUrl=Replace(ConsultUrl,"://",":\\")PrimitiveUrl=Replace(PrimitiveUrl,"\","/")If Right(ConsultUrl,1)<>"/" ThenIf Instr(ConsultUrl,"/")>0 ThenIf Instr(Right(ConsultUrl,Len(ConsultUrl)-InstrRev(ConsultUrl,"/")),".")>0 thenElseConsultUrl=ConsultUrl & "/"End IfElseConsultUrl=ConsultUrl & "/"End IfEnd IfConArray=Split(ConsultUrl,"/")If Left(LCase(PrimitiveUrl),7) = "http://" thenDefiniteUrl=Replace(PrimitiveUrl,"://",":\\")ElseIf Left(PrimitiveUrl,1) = "/" ThenDefiniteUrl=ConArray(0) & PrimitiveUrlElseIf Left(PrimitiveUrl,2)="./" ThenPrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-2)If Right(ConsultUrl,1)="/" ThenDefiniteUrl=ConsultUrl & PrimitiveUrlElseDefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrlEnd IfElseIf Left(PrimitiveUrl,3)="../" thenDo While Left(PrimitiveUrl,3)="../"PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-3)Pi=Pi+1LoopFor Ci=0 to (Ubound(ConArray)-1-Pi)If DefiniteUrl<>"" ThenDefiniteUrl=DefiniteUrl & "/" & ConArray(Ci)ElseDefiniteUrl=ConArray(Ci)End IfNextDefiniteUrl=DefiniteUrl & "/" & PrimitiveUrlElseIf Instr(PrimitiveUrl,"/")>0 ThenPriArray=Split(PrimitiveUrl,"/")If Instr(PriArray(0),".")>0 ThenIf Right(PrimitiveUrl,1)="/" ThenDefiniteUrl="http:\\" & PrimitiveUrlElseIf Instr(PriArray(Ubound(PriArray)-1),".")>0 ThenDefiniteUrl="http:\\" & PrimitiveUrlElseDefiniteUrl="http:\\" & PrimitiveUrl & "/"End IfEnd IfElseIf Right(ConsultUrl,1)="/" ThenDefiniteUrl=ConsultUrl & PrimitiveUrlElseDefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrlEnd IfEnd IfElseIf Instr(PrimitiveUrl,".")>0 ThenIf Right(ConsultUrl,1)="/" ThenIf right(LCase(PrimitiveUrl),3)=".cn" or right(LCase(PrimitiveUrl),3)="com" or right(LCase(PrimitiveUrl),3)="net" or right(LCase(PrimitiveUrl),3)="org" ThenDefiniteUrl="http:\\" & PrimitiveUrl & "/"ElseDefiniteUrl=ConsultUrl & PrimitiveUrlEnd IfElseIf right(LCase(PrimitiveUrl),3)=".cn" or right(LCase(PrimitiveUrl),3)="com" or right(LCase(PrimitiveUrl),3)="net" or right(LCase(PrimitiveUrl),3)="org" ThenDefiniteUrl="http:\\" & PrimitiveUrl & "/"ElseDefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrlEnd IfEnd IfElseIf Right(ConsultUrl,1)="/" ThenDefiniteUrl=ConsultUrl & PrimitiveUrl & "/"ElseDefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl & "/"End IfEnd IfEnd IfEnd IfIf Left(DefiniteUrl,1)="/" thenDefiniteUrl=Right(DefiniteUrl,Len(DefiniteUrl)-1)End ifIf DefiniteUrl<>"" ThenDefiniteUrl=Replace(DefiniteUrl,"//","/")DefiniteUrl=Replace(DefiniteUrl,":\\","://")ElseDefiniteUrl="$False$"End IfEnd Function'=================================================='函數名：ReplaceSaveRemoteFile'作 用：替換、儲存遠程圖片'參 數：ConStr —— 要替換的字串'參 數：SaveTf —— 是否儲存檔案，False不儲存，True儲存'參 數: TistUrl—— 當前網頁地址'==================================================Function ReplaceSaveRemoteFile(ConStr,strInstallDir,strChannelDir,SaveTf,TistUrl)If ConStr="$False$" or ConStr="" or strInstallDir="" or strChannelDir="" ThenReplaceSaveRemoteFile=ConStrExit FunctionEnd IfDim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2Set Re = New RegexpRe.IgnoreCase = TrueRe.Global = TrueRe.Pattern ="]>"Set Matches =Re.Execute(ConStr)For Each Match in MatchesIf TempStr<>"" thenTempStr=TempStr & "$Array$" & Match.ValueElseTempStr=Match.ValueEnd ifNextIf TempStr<>"" ThenTempArray=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 MatchesIf TempStr<>"" thenTempStr=TempStr & "$Array$" & Match.ValueElseTempStr=Match.ValueEnd ifNextNextEnd ifIf TempStr<>"" ThenRe.Pattern ="src\s*=\s*"TempStr=Re.Replace(TempStr,"")End IfSet Matches=nothingSet Re=nothingIf TempStr="" or IsNull(TempStr)=True ThenReplaceSaveRemoteFile=ConStrExit functionEnd ifTempStr=Replace(TempStr,"""","")TempStr=Replace(TempStr,"'","")TempStr=Replace(TempStr," ","")Dim RemoteFileurl,SavePath,PathTemp,DtNow,strFileName,strFileType,ArrSaveFileName,RanNum,Arr_PathDtNow=Now()If SaveTf=True then'***********************************SavePath= strChannelDir & "/" & year(DtNow) & right("0" & month(DtNow),2) & "/"   response.write "連結路徑：" & savepath & ""Arr_Path=Split(SavePath,"/")PathTemp=""For Tempi=0 To Ubound(Arr_Path)If Tempi=0 ThenPathTemp=Arr_Path(0) & "/"ElseIf Tempi=Ubound(Arr_Path) ThenExit ForElsePathTemp=PathTemp & Arr_Path(Tempi) & "/"End IfIf CheckDir(PathTemp)=False ThenIf MakeNewsDir(PathTemp)=False ThenSaveTf=FalseExit ForEnd IfEnd IfNextEnd If'去掉重複圖片開始TempArray=Split(TempStr,"$Array$")TempStr=""For Tempi=0 To Ubound(TempArray)If Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 ThenTempStr=TempStr & "$Array$" & TempArray(Tempi)End IfNextTempStr=Right(TempStr,Len(TempStr)-7)TempArray=Split(TempStr,"$Array$")'去掉重複圖片結束'轉換相對圖片地址開始TempStr=""For Tempi=0 To Ubound(TempArray)TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)NextTempStr=Right(TempStr,Len(TempStr)-7)TempStr=Replace(TempStr,Chr(0),"")TempArray2=Split(TempStr,"$Array$")TempStr=""'轉換相對圖片地址結束'圖片替換/儲存Set Re = New RegexpRe.IgnoreCase = TrueRe.Global = TrueFor 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" thenUploadFiles=""ReplaceSaveRemoteFile=ConStrExit FunctionEnd IfRandomizeRanNum=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 & "." & strFileTypeRe.Pattern =TempArray(Tempi)   If SaveRemoteFile(SavePath & strFileName,RemoteFileUrl)=True Then'********************************PathTemp=SavePath & strFileNameConStr=Re.Replace(ConStr,PathTemp)Re.Pattern=strInstallDir & strChannelDir & "/"UploadFiles=UploadFiles & "|" & Re.Replace(SavePath &strFileName,"")ElsePathTemp=RemoteFileUrlConStr=Re.Replace(ConStr,PathTemp)'UploadFiles=UploadFiles & "|" & RemoteFileUrlEnd IfElseIf RemoteFileurl<>"$False$" and SaveTf=False Then'不儲存圖片Re.Pattern =TempArray(Tempi)ConStr=Re.Replace(ConStr,RemoteFileUrl)UploadFiles=UploadFiles & "|" & RemoteFileUrlEnd IfNextSet Re=nothingIf UploadFiles<>"" ThenUploadFiles=Right(UploadFiles,Len(UploadFiles)-1)End IfReplaceSaveRemoteFile=ConStrEnd function'=================================================='函數名：ReplaceSwfFile'作 用：解析動畫路徑'參 數：ConStr —— 要替換的字串'參 數: TistUrl—— 當前網頁地址'==================================================Function ReplaceSwfFile(ConStr,TistUrl)If ConStr="$False$" or ConStr="" or TistUrl="" or TistUrl="$False$" ThenReplaceSwfFile=ConStrExit FunctionEnd IfDim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2Set Re = New RegexpRe.IgnoreCase = TrueRe.Global = TrueRe.Pattern ="]>"Set Matches =Re.Execute(ConStr)For Each Match in MatchesIf TempStr<>"" thenTempStr=TempStr & "$Array$" & Match.ValueElseTempStr=Match.ValueEnd ifNextIf TempStr<>"" ThenTempArray=Split(TempStr,"$Array$")TempStr=""For Tempi=0 To Ubound(TempArray)Re.Pattern ="value\s*=\s*.+?\.swf"Set Matches =Re.Execute(TempArray(Tempi))For Each Match in MatchesIf TempStr<>"" thenTempStr=TempStr & "$Array$" & Match.ValueElseTempStr=Match.ValueEnd ifNextNextEnd ifIf TempStr<>"" ThenRe.Pattern ="value\s*=\s*"TempStr=Re.Replace(TempStr,"")End IfIf TempStr="" or IsNull(TempStr)=True ThenReplaceSwfFile=ConStrExit functionEnd ifTempStr=Replace(TempStr,"""","")TempStr=Replace(TempStr,"'","")TempStr=Replace(TempStr," ","")Set Matches=nothingSet Re=nothing'去掉重複檔案開始TempArray=Split(TempStr,"$Array$")TempStr=""For Tempi=0 To Ubound(TempArray)If Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 ThenTempStr=TempStr & "$Array$" & TempArray(Tempi)End IfNextTempStr=Right(TempStr,Len(TempStr)-7)TempArray=Split(TempStr,"$Array$")'去掉重複檔案結束'轉換相對位址開始TempStr=""For Tempi=0 To Ubound(TempArray)TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)NextTempStr=Right(TempStr,Len(TempStr)-7)TempStr=Replace(TempStr,Chr(0),"")TempArray2=Split(TempStr,"$Array$")TempStr=""'轉換相對位址結束'替換Set Re = New RegexpRe.IgnoreCase = TrueRe.Global = TrueFor Tempi=0 To Ubound(TempArray2)RemoteFileUrl=TempArray2(Tempi)Re.Pattern =TempArray(Tempi)ConStr=Re.Replace(ConStr,RemoteFileUrl)NextSet Re=nothingReplaceSwfFile=ConStrEnd function'=================================================='過程名：SaveRemoteFile'作 用：儲存遠端檔案到本地'參 數：LocalFileName ------ 本地檔案名稱'參 數：RemoteFileUrl ------ 遠程檔案URL'==================================================Function SaveRemoteFile(LocalFileName,RemoteFileUrl)SaveRemoteFile=True  dim Ads,Retrieval,GetRemoteData  Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")  With Retrieval    .Open "Get", RemoteFileUrl, False, "", ""    .SendIf .Readystate<>4 thenSaveRemoteFile=FalseExit FunctionEnd 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=nothingend Function'=================================================='函數名：FpHtmlEnCode'作 用：標題過濾'參 數：fString ——字串'==================================================Function FpHtmlEnCode(fString)If IsNull(fString)=False or fString<>"" or fString<>"$False$" ThenfString=nohtml(fString)fString=FilterJS(fString)fString = Replace(fString," "," ")fString = Replace(fString,""","")fString = Replace(fString,"'","")fString = replace(fString, ">", "")fString = replace(fString, "<", "")fString = Replace(fString, CHR(9), " ")' fString = Replace(fString, CHR(10), "")fString = Replace(fString, CHR(13), "")fString = Replace(fString, CHR(34), "")fString = Replace(fString, CHR(32), " ") 'spacefString = Replace(fString, CHR(39), "")fString = Replace(fString, CHR(10) & CHR(10),"")fString = Replace(fString, CHR(10)&CHR(13), "")fString=Trim(fString)FpHtmlEnCode=fStringElseFpHtmlEnCode="$False$"End IfEnd Function