Asp collection program

'================================================ ========== 'Function Name: getHttpPage: Get webpage source code parameter: httpUrl -- webpage address '======================================== ================== 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' ============================================= ============== 'function Name: bytesToBstr 'for usage: Convert the obtained source code to the Chinese character' parameter number: Body -- variable to be converted 'parameter Number: cset -- type to be converted '================================== ====================== Function BytesToBstr (Body, cset) Dim ObjstreamSet Objstre Am = Server. createObject ("adodb. stream ") objstream. type = 1objstream. mode = 3objstream. openobjstream. write bodyobjstream. position = 0objstream. type = 2objstream. charset = CsetBytesToBstr = objstream. readTextobjstream. closeset objstream = nothingEnd function' ================================ ================== 'function Name: urlEncoding: conversion encoding '============================================ =============== Function UrlEncodi Ng (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 & Signature = Asc (ThisChr) If InnerCode <0 ThenInnerCode = InnerCode + & hsf-end IfHight8 = (InnerCode And & HFF00) \ & HFFLow8 = InnerCode And & HFFStrReturn = StrReturn & "%" & Hex (Hight8) & "%" & Hex (Low8) End If NextUrlEncoding = StrReturnEnd function' ================================ ================ 'function Name: getBody 'usage: Truncated string' parameter: ConStr ------ string to be truncated 'parameter: StartStr ------ start string' parameter: OverStr ------ end string' parameter: incluL ------ whether the parameter 'startstr' is included: incluR ------ include OverStr '====================================== ==================== Function GetBody (ConStr, startStr, OverStr, IncluL, IncluR) If ConStr = "$ False $" or ConStr = "" or IsNull (ConSt R) = 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 = Limit B (1, conStrTemp, StartStr, vbBinaryCompare) If Start <= 0 thenGetBody = "$ False $" Exit FunctionElseIf IncluL = False ThenStart = Start + LenB (StartStr) End IfEnd IfOver = Limit B (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' ============================================ ============== 'function Name: getArray 'usage: extract the link address, separated by $ Array $ 'parameter: ConStr ------ extract the address's original character' parameter: StartStr ------ start string' parameter: overStr ------ end string 'parameter: IncluL ------ include startstr' Parameters: incluR ------ include 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 RegexpobjR EgExp. 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 (TempSt R, "") 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' ============== =============================' Function Name: definiteUrl 'for usage: Convert relative address to absolute address' parameter number: PrimitiveUrl ------ relative address to be converted 'Parameter Quantity: consultUrl ------ current webpage address '==================================== =================== 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)-Comment Rev (ConsultUrl ,"/")),". ")> 0 thenElseConsultUrl = ConsultUrl &"/"End IfElseConsultUrl = ConsultUrl &"/"End IfEnd IfConArray = Split (ConsultUrl,"/") If Left (LCase (PrimitiveUrl ), 7) = "ht Tp: // "thenDefiniteUrl = Replace (PrimitiveUrl,": // ",": \ ") ElseIf Left (PrimitiveUrl, 1) ="/"ThenDefiniteUrl = ConArray (0) & PrimitiveUrlElseIf Left (PrimitiveUrl, 2) = ". /"response = Right (PrimitiveUrl, Len (PrimitiveUrl)-2) If Right (ConsultUrl, 1) ="/"ThenDefiniteUrl = ConsultUrl & response = Left (ConsultUrl, limit Rev (ConsultUrl, "/") & PrimitiveUrlEnd IfElseIf Left (PrimitiveUrl, 3) = ".. /" ThenDo While Left (PrimitiveUrl, 3) = ".. /"PrimitiveUrl = Right (PrimitiveUrl, Len (PrimitiveUrl)-3) Pi = Pi + 1 LoopFor Ci = 0 to (Ubound (ConArray)-1-Pi) if DefiniteUrl <> "" ThenDefiniteUrl = DefiniteUrl & "/" & ConArray (Ci) ElseDefiniteUrl = ConArray (Ci) End IfNextDefiniteUrl = DefiniteUrl & "/" & incluinstr (PrimitiveUrl, "/")> 0 ThenPriArray = Split (PrimitiveUrl, "/") If Instr (PriArray (0 ),". ")> 0 ThenIf Right (Pri MitiveUrl, 1) = "/" ThenDefiniteUrl = "http: \" & PrimitiveUrlElseIf Instr (PriArray (Ubound (PriArray)-1 ),". ")> 0 ThenDefiniteUrl =" http: \ "& PrimitiveUrlElseDefiniteUrl =" http: \ "& PrimitiveUrl &"/"End IfEnd IfElseIf Right (ConsultUrl, 1) = "/" ThenDefiniteUrl = ConsultUrl & tags = Left (ConsultUrl, comment Rev (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, limit Rev (ConsultUrl ,"/")) & "/" & incluifend IfElseIf Right (ConsultUrl, 1) = "/" ThenDefiniteUrl = ConsultUrl & PrimitiveUrl & "/" ElseDefiniteUrl = Left (ConsultUrl, limit Rev (ConsultUrl, "/") & "/" & PrimitiveUrl & "/" End 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' ======================== =================================' Function Name: replaceSaveRemoteFile: replace and save remote image parameter: ConStr -- string to be replaced 'parameter: SaveTf -- whether to save the file, False not to save, True to save' parameter: tistUrl -- current webpage address '==================================== ===== ============ 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 "link path:" & savepath & "" Arr_Path = S Plit (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 'remove the duplicate image and start TempArray = Split (TempStr, "$ Array $") TempStr = "" For Tempi = 0 To Ubound (TempArray) if Instr (Lca Se (TempStr), Lcase (TempArray (Tempi) <1 ThenTempStr = TempStr & "$ Array $" & TempArray (Tempi) End IfNextTempStr = Right (TempStr, Len (TempStr) -7) TempArray = Split (TempStr, "$ Array $") 'remove duplicate image terminologies convert relative image address start 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 =" "'convert relative to image address' image replacement/save Set Re = New RegexpRe. ignoreCase = TrueRe. global = TrueFor Tempi = 0 To Ubound (TempArray2) RemoteFileUrl = TempArray2 (Tempi) If RemoteFileUrl <> "$ False $" And SaveTf = True then' Save the image ArrSaveFileName = Split (RemoteFileurl, ". ") strFileType = Lcase (ArrSaveFileName (Ubound (ArrSaveFileName) 'file type 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 partition = 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 = T EmpArray (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 & "|" & RemoteFileUrlE Nd IfElseIf RemoteFileurl <> "$ False $" and SaveTf = False then' do not save the Image 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' ================================ ================== 'function Name: replaceSwfFile 'use: parse animation Path' Parameter: ConStr -- string to be replaced 'parameter: tistUrl -- current webpage address '==================================== ==================== 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 'remove duplicate files and start 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 $ ") 'Remove duplicate file' the relative address of the conversion starts 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 = "" 'convert relative address terminate' replace 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' ========================== ===========================' process name: saveRemoteFile 'for use: Save remote file to local' parameter: LocalFileName ------ local filename 'parameter: remoteFileUrl ------ Remote File 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' ============================== =========================' Function Name: fpHtmlEnCode is used as the title filter parameter: fString -- string '========================================== ================= 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