創(chuàng)力采集程序用到的函數(shù) 推薦第2/3頁
更新時(shí)間：2006年09月01日 00:00:00 作者：
復(fù)制代碼 代碼如下:
'==================================================
'函數(shù)名：DefiniteUrl
'作 用：將相對(duì)地址轉(zhuǎn)換為絕對(duì)地址
'參 數(shù)：PrimitiveUrl ------要轉(zhuǎn)換的相對(duì)地址
'參 數(shù)：ConsultUrl ------當(dāng)前網(wǎng)頁地址
'==================================================
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
ConsultUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/"))
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) & Replace(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
Pi=0
Do While Left(PrimitiveUrl,3)="../"
PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-3)
Pi=Pi+1
Loop
If Ubound(ConArray)-Pi>0 Then
For Ci=0 to (Ubound(ConArray)-Pi)
If DefiniteUrl<>"" Then
DefiniteUrl=DefiniteUrl & "/"
Else
DefiniteUrl=ConArray(Ci)
End If
Next
DefiniteUrl=DefiniteUrl & "/" & PrimitiveUrl
Else
DefiniteUrl=ConArray(0) & "/" & PrimitiveUrl
End if
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),4)=".com" or right
(LCase(PrimitiveUrl),4)=".net" or right(LCase(PrimitiveUrl),4)=".org" or right(LCase(PrimitiveUrl),5)
=".info" Then
DefiniteUrl="http:\\" & PrimitiveUrl & "/"
Else
DefiniteUrl=ConsultUrl & PrimitiveUrl
End If
Else
If right(LCase(PrimitiveUrl),3)=".cn" or right(LCase(PrimitiveUrl),4)=".com" or right
(LCase(PrimitiveUrl),4)=".net" or right(LCase(PrimitiveUrl),4)=".org" or right(LCase(PrimitiveUrl),5)
=".info" 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,"http://","/")
DefiniteUrl=Replace(DefiniteUrl,":\\","://")
Else
DefiniteUrl="$False$"
End If
End Function
'==================================================
'函數(shù)名：ReplaceSaveRemoteFile
'作 用：替換、保存遠(yuǎn)程圖片
'參 數(shù)：ConStr ------ 要替換的字符串
'參 數(shù)：SaveTf ------ 是否保存文件，F(xiàn)alse不保存，True保存
'參 數(shù): TistUrl------ 當(dāng)前網(wǎng)頁地址
'==================================================
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
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=Cl.UpLoadDir & "Editor/" & year(DtNow) &"-"& month(DtNow) & "/"
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
'去掉重復(fù)圖片開始
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$")
'去掉重復(fù)圖片結(jié)束
'轉(zhuǎn)換相對(duì)圖片地址開始
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=""
'轉(zhuǎn)換相對(duì)圖片地址結(jié)束
'圖片替換/保存
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,Cl.UpLoadDir,"{%uploaddir%}")
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
'==================================================
'函數(shù)名：ReplaceSwfFile
'作 用：解析動(dòng)畫路徑
'參 數(shù)：ConStr ------ 要替換的字符串
'參 數(shù): TistUrl------ 當(dāng)前網(wǎng)頁地址
'==================================================
Function ReplaceSwfFile(ConStr,TistUrl)
If ConStr="$False$" or ConStr="" or TistUrl="" or TistUrl="$False$" Then
ReplaceSwfFile=ConStr
Exit Function
End If
Dim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2
Set Re = New Regexp
Re.IgnoreCase = True
Re.Global = True
Re.Pattern ="<object.+?[^\>]>"
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 ="value\s*=\s*.+?\.swf"
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 ="value\s*=\s*"
TempStr=Re.Replace(TempStr,"")
End If
If TempStr="" or IsNull(TempStr)=True Then
ReplaceSwfFile=ConStr
Exit function
End if
TempStr=Replace(TempStr,"""","")
TempStr=Replace(TempStr,"'","")
TempStr=Replace(TempStr," ","")
Set Matches=Nothing
Set Re=Nothing
'去掉重復(fù)文件開始
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$")
'去掉重復(fù)文件結(jié)束
'轉(zhuǎn)換相對(duì)地址開始
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=""
'轉(zhuǎn)換相對(duì)地址結(jié)束
'替換
Set Re = New Regexp
Re.IgnoreCase = True
Re.Global = True
For Tempi=0 To Ubound(TempArray2)
RemoteFileUrl=TempArray2(Tempi)
Re.Pattern =TempArray(Tempi)
ConStr=Re.Replace(ConStr,RemoteFileUrl)
Next
Set Re=Nothing
ReplaceSwfFile=ConStr
End function
相關(guān)文章
XMLHTTP利用POST發(fā)送表單時(shí)提交中文的問題
XMLHTTP利用POST發(fā)送表單時(shí)提交中文的問題...2006-06-06
一個(gè)帶采集遠(yuǎn)程文章內(nèi)容,保存圖片,生成文件等完整的采集功能
本文提供了一套完整的ASP采集功能函數(shù),包含提取地址的原字符,保存遠(yuǎn)程的文件到本地模擬登錄,獲取網(wǎng)頁源碼等功能函數(shù)2009-06-06
小偷&小偷入庫&采集入庫...2006-07-07
如果你不會(huì)寫asp采集，那么代碼你可能不懂，那就不是我這次發(fā)帖所討論了，希望對(duì)大家有用。2008-10-10
研究網(wǎng)頁編碼很長時(shí)間了，因?yàn)樽罱O(shè)計(jì)一個(gè)友情鏈接檢測(cè)的VBS腳本，而與你鏈接的人的頁面很可能是各種編碼2008-07-07
網(wǎng)站生成靜態(tài)頁面攻略2:數(shù)據(jù)采集
網(wǎng)站生成靜態(tài)頁面攻略2:數(shù)據(jù)采集...2006-08-08
在瀏覽器的地址欄里直接輸入一個(gè)doc或xls或jpg的文件的url路徑，那么該文件會(huì)直接顯示在瀏覽器里。而在很多時(shí)候我們希望能直接彈出下載提示框讓用戶下載，我們?cè)撛趺崔k呢2007-12-12
ASP遠(yuǎn)程保存圖片...2006-07-07
幫你打造屬于自己的搜索引擎---百度篇...2006-09-09
如何寫ASP入庫小偷程序...2007-06-06