首页 / ASP / 一个带采集远程文章内容,保存图片,生成文件等完整的采集功能

一个带采集远程文章内容,保存图片,生成文件等完整的采集功能

内容导读

互联网集市收集整理的这篇技术教程文章主要介绍了一个带采集远程文章内容,保存图片,生成文件等完整的采集功能，小编现在分享给大家，供广大互联网技能从业者学习和参考。文章包含32484字，纯文字阅读大概需要47分钟。

内容图文

代码如下:
'==================================================
'函数名：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("MSX" & "ML2.XM" & "LHT" & "TP")
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")
GetHTTPPage=replace(replace(GetHTTPPage , vbCr,""),vbLf,"")
Set Http=Nothing
If Err.number<>0 then
Err.Clear
End If
End Function

'==================================================
'函数名：BytesToBstr
'作用：将获取的源码转换为中文
'参数：Body ------要转换的变量
'参数：Cset ------要转换的类型
'==================================================
Function BytesToBstr(Body,Cset)
Dim Objstream
Set Objstream = Server.CreateObject("ad" & "odb.str" & "eam")
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 = nothing
End Function

'==================================================
'函数名：PostHttpPage
'作用：登录
'==================================================
Function PostHttpPage(RefererUrl,PostUrl,PostData)
Dim xmlHttp
Dim RetStr
Set xmlHttp = CreateObject("Msx" & "ml2.XM" & "LHT" & "TP")
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.Send PostData
If Err.Number <> 0 Then
Set xmlHttp=Nothing
PostHttpPage = "$False$"
Exit Function
End If
PostHttpPage=bytesToBSTR(xmlHttp.responseBody,"GB2312")
Set xmlHttp = nothing
End 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 = StrReturn
End 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 Then
GetBody="$False$"
Exit Function
End If
Dim ConStrTemp
Dim Start,Over
ConStrTemp=Lcase(ConStr)
StartStr=Lcase(StartStr)
OverStr=Lcase(OverStr)
Start = InStrB(1, ConStrTemp, StartStr, vbBinaryCompare)
If Start<=0 then
GetBody="$False$"
Exit Function
Else
If IncluL=False Then
Start=Start+LenB(StartStr)
End If
End If
Over=InStrB(Start,ConStrTemp,OverStr,vbBinaryCompare)
If Over<=0 Or Over<=Start then
GetBody="$False$"
Exit Function
Else
If IncluR=True Then
Over=Over+LenB(OverStr)
End If
End If
GetBody=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 Then
GetArray="$False$"
Exit Function
End If
Dim TempStr,TempStr2,objRegExp,Matches,Match
TempStr=""
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "("&StartStr&").+?("&OverStr&")"
Set Matches =objRegExp.Execute(ConStr)
For Each Match in Matches
TempStr=TempStr & "$Array$" & Match.Value
Next
Set Matches=nothing

If TempStr="" Then
GetArray="$False$"
Exit Function
End If
TempStr=Right(TempStr,Len(TempStr)-7)
If IncluL=False then
objRegExp.Pattern =StartStr
TempStr=objRegExp.Replace(TempStr,"")
End if
If IncluR=False then
objRegExp.Pattern =OverStr
TempStr=objRegExp.Replace(TempStr,"")
End if
Set objRegExp=nothing
Set Matches=nothing

TempStr=Replace(TempStr,"""","")
TempStr=Replace(TempStr,"'","")
TempStr=Replace(TempStr," ","")
TempStr=Replace(TempStr,"(","")
TempStr=Replace(TempStr,")","")

If TempStr="" then
GetArray="$False$"
Else
GetArray=TempStr
End if
End Function

'==================================================
'函数名：DefiniteUrl
'作用：将相对地址转换为绝对地址
'参数：PrimitiveUrl ------要转换的相对地址
'参数：ConsultUrl ------当前网页地址
'==================================================
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
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) & 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
Do While Left(PrimitiveUrl,3)="../"
PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-3)
Pi=Pi+1
Loop
For Ci=0 to (Ubound(ConArray)-1-Pi)
If DefiniteUrl<>"" Then
DefiniteUrl=DefiniteUrl & "/" & ConArray(Ci)
Else
DefiniteUrl=ConArray(Ci)
End If
Next
DefiniteUrl=DefiniteUrl & "/" & PrimitiveUrl
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),3)="com" or right(LCase(PrimitiveUrl),3)="net" or right(LCase(PrimitiveUrl),3)="org" Then
DefiniteUrl="http:\\" & PrimitiveUrl & "/"
Else
DefiniteUrl=ConsultUrl & PrimitiveUrl
End If
Else
If right(LCase(PrimitiveUrl),3)=".cn" or right(LCase(PrimitiveUrl),3)="com" or right(LCase(PrimitiveUrl),3)="net" or right(LCase(PrimitiveUrl),3)="org" 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,"//","/")
DefiniteUrl=Replace(DefiniteUrl,":\\","://")
Else
DefiniteUrl="$False$"
End If
End Function

'==================================================
'函数名：ReplaceSaveRemoteFile
'作用：替换、保存远程图片
'参数：ConStr ------ 要替换的字符串
'参数：SaveTf ------ 是否保存文件，False不保存，True保存
'参数: TistUrl------ 当前网页地址
'==================================================
Function ReplaceSaveRemoteFile(ConStr,InstallPath,strChannelDir,SaveTf,TistUrl)
If ConStr="$False$" or ConStr="" or InstallPath="" 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*.+?\.(gifjpgbmpjpegpsdpngsvgdxfwmftiff)"
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=InstallPath&strChannelDir
If CheckDir(InstallPath & strChannelDir)=False Then
If Not CreateMultiFolder(InstallPath & strChannelDir) Then
response.Write InstallPath & strChannelDir&"目录创建失败"
SaveTf=False
End If
End If
End If

'去掉重复图片开始
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$")
'去掉重复图片结束

response.Write " 发现图片: "&Replace(TempStr,"$Array$"," ")

'转换相对图片地址开始
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=""
'转换相对图片地址结束

'图片替换/保存
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)
response.Write " 保存到本地地址:"&InstallPath & strChannelDir & strFileName
If SaveRemoteFile(InstallPath & strChannelDir & strFileName,RemoteFileUrl,RemoteFileUrl)=True Then
response.Write "成功 "
PathTemp=InstallPath & strChannelDir & strFileName
ConStr=Re.Replace(ConStr,PathTemp)
Re.Pattern=InstallPath&strChannelDir
UploadFiles=UploadFiles & "" & InstallPath & strChannelDir & strFileName
Else
PathTemp=RemoteFileUrl
ConStr=Re.Replace(ConStr,PathTemp)
End If
ElseIf RemoteFileurl<>"$False$" and SaveTf=False Then'不保存图片
Re.Pattern =TempArray(Tempi)
ConStr=Re.Replace(ConStr,RemoteFileUrl)
End If
'********************************
Next
Set Re=nothing
ReplaceSaveRemoteFile=ConStr
End function

'==================================================
'函数名：ReplaceSwfFile
'作用：解析动画路径
'参数：ConStr ------ 要替换的字符串
'参数: TistUrl------ 当前网页地址
'==================================================
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

'去掉重复文件开始
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$")
'去掉重复文件结束

'转换相对地址开始
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=""
'转换相对地址结束

'替换
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

'==================================================
'过程名：SaveRemoteFile
'作用：保存远程的文件到本地
'参数：LocalFileName ------ 本地文件名
'参数：RemoteFileUrl ------ 远程文件URL
'参数：Referer ------ 远程调用文件（对付防采集的，用内容页地址，没有防的留空）
'==================================================
Function SaveRemoteFile(LocalFileName,RemoteFileUrl,Referer)
SaveRemoteFile=True
dim Ads,Retrieval,GetRemoteData
Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
With Retrieval
.Open "Get", RemoteFileUrl, False, "", ""
if Referer<>"" then .setRequestHeader "Referer",Referer
.Send
If .Readystate<>4 then
SaveRemoteFile=False
Exit Function
End 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=nothing
end Function

'==================================================
'函数名：GetPaing
'作用：获取分页
'==================================================
Function GetPaing(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
If ConStr="$False$" or ConStr="" Or StartStr="" Or OverStr="" or IsNull(ConStr)=True or IsNull(StartStr)=True Or IsNull(OverStr)=True Then
GetPaing="$False$"
Exit Function
End If

Dim Start,Over,ConTemp,TempStr
TempStr=LCase(ConStr)
StartStr=LCase(StartStr)
OverStr=LCase(OverStr)
Over=Instr(1,TempStr,OverStr)
If Over<=0 Then
GetPaing="$False$"
Exit Function
Else
If IncluR=True Then
Over=Over+Len(OverStr)
End If
End If
TempStr=Mid(TempStr,1,Over)
Start=InstrRev(TempStr,StartStr)
If IncluL=False Then
Start=Start+Len(StartStr)
End If

If Start<=0 Or Start>=Over Then
GetPaing="$False$"
Exit Function
End If
ConTemp=Mid(ConStr,Start,Over-Start)

ConTemp=Trim(ConTemp)
'ConTemp=Replace(ConTemp," ","")
ConTemp=Replace(ConTemp,",","")
ConTemp=Replace(ConTemp,"'","")
ConTemp=Replace(ConTemp,"""","")
ConTemp=Replace(ConTemp,">","")
ConTemp=Replace(ConTemp,"<","")
ConTemp=Replace(ConTemp," ;","")
GetPaing=ConTemp
End Function

'*************************************************
'函数名：gotTopic
'作用：截字符串，汉字一个算两个字符，英文算一个字符
'参数：str ----原字符串
' strlen ----截取长度
'返回值：截取后的字符串
'*************************************************
function gotTopic(str,strlen)
if str="" then
gotTopic=""
exit function
end if
dim l,t,c, i
str=replace(replace(replace(replace(str," "," "),""",chr(34)),">",">"),"<","<")
l=len(str)
t=0
for i=1 to l
c=Abs(Asc(Mid(str,i,1)))
if c>255 then
t=t+2
else
t=t+1
end if
if t>=strlen then
gotTopic=left(str,i) & "…"
exit for
else
gotTopic=str
end if
next
gotTopic=replace(replace(replace(replace(gotTopic," "," "),chr(34),"""),">",">"),"<","<;")
end function

'***********************************************
'函数名：JoinChar
'作用：向地址中加入 ? 或 &
'参数：strUrl ----网址
'返回值：加了 ? 或 & 的网址
'***********************************************
function JoinChar(strUrl)
if strUrl="" then
JoinChar=""
exit function
end if
if InStr(strUrl,"?")<len(strUrl) then
if InStr(strUrl,"?")>1 then
if InStr(strUrl,"&")<len(strUrl) then
JoinChar=strUrl & "&"
else
JoinChar=strUrl
end if
else
JoinChar=strUrl & "?"
end if
else
JoinChar=strUrl
end if
end function

'**************************************************
'函数名：CreateKeyWord
'作用：由给定的字符串生成关键字
'参数：Constr---要生成关键字的原字符串
'返回值：生成的关键字
'**************************************************
Function CreateKeyWord(byval Constr,Num)
If Constr="" or IsNull(Constr)=True or Constr="$False$" Then
CreateKeyWord="$False$"
Exit Function
End If
If Num="" or IsNumeric(Num)=False Then
Num=2
End If
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,">","")
Constr=Replace(Constr,"""","")
Constr=Replace(Constr,"?","")
Constr=Replace(Constr,"*","")
Constr=Replace(Constr,"","")
Constr=Replace(Constr,",","")
Constr=Replace(Constr,".","")
Constr=Replace(Constr,"/","")
Constr=Replace(Constr,"\","")
Constr=Replace(Constr,"-","")
Constr=Replace(Constr,"@","")
Constr=Replace(Constr,"#","")
Constr=Replace(Constr,"$","")
Constr=Replace(Constr,"%","")
Constr=Replace(Constr,"&","")
Constr=Replace(Constr,"+","")
Constr=Replace(Constr,":","")
Constr=Replace(Constr,"：","")
Constr=Replace(Constr,"‘","")
Constr=Replace(Constr,"“","")
Constr=Replace(Constr,"”","")
Dim i,ConstrTemp
For i=1 To Len(Constr)
ConstrTemp=ConstrTemp & "" & Mid(Constr,i,Num)
Next
If Len(ConstrTemp)<254 Then
ConstrTemp=ConstrTemp & ""
Else
ConstrTemp=Left(ConstrTemp,254) & ""
End If
CreateKeyWord=ConstrTemp
End Function

'==================================================
'函数名：CheckUrl
'作用：检查Url
'参数：strUrl ------ 要检查Url
'==================================================
Function CheckUrl(strUrl)
Dim Re
Set Re=new RegExp
Re.IgnoreCase =true
Re.Global=True
Re.Pattern="http://([\w-]+\.)+[\w-]+(/[\w-./?%&=]*)?"
If Re.test(strUrl)=True Then
CheckUrl=strUrl
Else
CheckUrl="$False$"
End If
Set Rs=Nothing
End 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=Nothing
End Function

'==================================================
'函数名：RemoveHTML
'作用：完全去除html标记
'参数：strHTML ------ 要过滤的字符串
'==================================================
Function RemoveHTML(strHTML)
Dim objRegExp, Match, Matches
Set objRegExp = New Regexp

objRegExp.IgnoreCase = True
objRegExp.Global = True
'取闭合的<>
objRegExp.Pattern = "<.+?>"
'进行匹配
Set Matches = objRegExp.Execute(strHTML)

' 遍历匹配集合，并替换掉匹配的项目
For Each Match in Matches
strHtml=Replace(strHTML,Match.Value,"")
Next
RemoveHTML=strHTML
Set objRegExp = Nothing
End Function

'==================================================
'函数名：CheckDir
'作用：检查文件夹是否存在
'参数：FolderPath ------ 文件夹路径
'==================================================
Function CheckDir(byval FolderPath)
dim fso
Set fso = Server.CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(Server.MapPath(folderpath)) then
'存在
CheckDir = True
Else
'不存在
CheckDir = False
End if
Set fso = nothing
End Function

'==================================================
'函数名：MakeNewsDir
'作用：创建文件夹
'参数：foldername ------ 文件夹名
'==================================================
Function MakeNewsDir(byval foldername)
dim fso
Set fso = Server.CreateObject("Scri" & "pti" & "ng.Fil" & "eSyst" & "emOb" & "ject")
fso.CreateFolder(Server.MapPath(foldername))
If fso.FolderExists(Server.MapPath(foldername)) Then
MakeNewsDir = True
Else
MakeNewsDir = False
End If
Set fso = nothing
End Function

'==================================================
'函数名：DelDir
'作用：创建文件夹
'参数：foldername ------ 文件夹名
'==================================================
Function DelDir(byval foldername)
dim fso
Set fso = Server.CreateObject("Scri" & "pti" & "ng.Fil" & "eSyst" & "emOb" & "ject")
If fso.FolderExists(Server.MapPath(foldername)) Then '判断文件夹是否存在
fso.DeleteFolder (Server.MapPath(foldername)) '删除文件夹
End If
Set fso = nothing
End Function

'**************************************************
'函数名：IsObjInstalled
'作用：检查组件是否已经安装
'参数：strClassString ----组件名
'返回值：True ----已经安装
' False ----没有安装
'**************************************************
Function IsObjInstalled(strClassString)
IsObjInstalled = False
Err = 0
Dim xTestObj
Set xTestObj = Server.CreateObject(strClassString)
If 0 = Err Then IsObjInstalled = True
Set xTestObj = Nothing
Err = 0
End Function

'**************************************************
'函数名：strLength
'作用：求字符串长度。汉字算两个字符，英文算一个字符。
'参数：str ----要求长度的字符串
'返回值：字符串长度
'**************************************************
function strLength(str)
ON ERROR RESUME NEXT
dim WINNT_CHINESE
WINNT_CHINESE = (len("中国")=2)
if WINNT_CHINESE then
dim l,t,c
dim i
l=len(str)
t=l
for i=1 to l
c=asc(mid(str,i,1))
if c<0 then c=c+65536
if c>255 then
t=t+1
end if
next
strLength=t
else
strLength=len(str)
end if
if err.number<>0 then err.clear
end function

'****************************************************
'函数名：CreateMultiFolder
'作用：创建多级目录，可以创建不存在的根目录
'参数：要创建的目录名称，可以是多级
'返回逻辑值：True成功，False失败
'创建目录的根目录从当前目录开始
'****************************************************
Function CreateMultiFolder(ByVal CFolder)
Dim objFSO,PhCreateFolder,CreateFolderArray,CreateFolder
Dim i,ii,CreateFolderSub,PhCreateFolderSub,BlInfo
BlInfo = False
CreateFolder = CFolder
On Error Resume Next
Set objFSO = Server.CreateObject("Scri" & "pti" & "ng.Fil" & "eSyst" & "emOb" & "ject")
If Err Then
Err.Clear()
Exit Function
End If
CreateFolder = Replace(CreateFolder,"\","/")
If Left(CreateFolder,1)="/" Then
'CreateFolder = Right(CreateFolder,Len(CreateFolder)-1)
End If
If Right(CreateFolder,1)="/" Then
CreateFolder = Left(CreateFolder,Len(CreateFolder)-1)
End If
CreateFolderArray = Split(CreateFolder,"/")
For i = 0 to UBound(CreateFolderArray)
CreateFolderSub = ""
For ii = 0 to i
CreateFolderSub = CreateFolderSub & CreateFolderArray(ii) & "/"
Next
PhCreateFolderSub = Server.MapPath(CreateFolderSub)

'response.Write PhCreateFolderSub&" "

If Not objFSO.FolderExists(PhCreateFolderSub) Then
objFSO.CreateFolder(PhCreateFolderSub)
End If
Next
If Err Then
Err.Clear()
Else
BlInfo = True
End If
Set objFSO=nothing
CreateMultiFolder = BlInfo
End Function

'**************************************************
'函数名：FSOFileRead
'作用：使用FSO读取文件内容的函数
'参数：filename ----文件名称
'返回值：文件内容
'**************************************************
function FSOFileRead(filename)
Dim objFSO,objCountFile,FiletempData
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objCountFile = objFSO.OpenTextFile(Server.MapPath(filename),1,True)
FSOFileRead = objCountFile.ReadAll
objCountFile.Close
Set objCountFile=Nothing
Set objFSO = Nothing
End Function

'**************************************************
'函数名：FSOlinedit
'作用：使用FSO读取文件某一行的函数
'参数：filename ----文件名称
' lineNum ----行数
'返回值：文件该行内容
'**************************************************
function FSOlinedit(filename,lineNum)
if linenum < 1 then exit function
dim fso,f,temparray,tempcnt
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.AtEndofStream then
tempcnt = f.readall
f.close
set f = nothing
temparray = split(tempcnt,chr(13)&chr(10))
if lineNum>ubound(temparray)+1 then
exit function
else
FSOlinedit = temparray(lineNum-1)
end if
end if
end function

'**************************************************
'函数名：FSOlinewrite
'作用：使用FSO写文件某一行的函数
'参数：filename ----文件名称
' lineNum ----行数
' Linecontent ----内容
'返回值：无
'**************************************************
function FSOlinewrite(filename,lineNum,Linecontent)
if linenum < 1 then exit function
dim fso,f,temparray,tempCnt
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.AtEndofStream then
tempcnt = f.readall
f.close
temparray = split(tempcnt,chr(13)&chr(10))
if lineNum>ubound(temparray)+1 then
exit function
else
temparray(lineNum-1) = lineContent
end if
tempcnt = join(temparray,chr(13)&chr(10))
set f = fso.createtextfile(server.mappath(filename),true)
f.write tempcnt
end if
f.close
set f = nothing
end function

'**************************************************
'函数名：Htmlmake
'作用：使用FSO创建文件
'参数：HtmlFolder ----路径
' HtmlFilename ----文件名
' HtmlContent ----内容
'**************************************************
function Htmlmake(HtmlFolder,HtmlFilename,HtmlContent)
On Error Resume Next
dim filepath,fso,fout
filepath = HtmlFolder&"/"&HtmlFilename
Set fso = Server.CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(HtmlFolder) Then
Else
CreateMultiFolder(HtmlFolder)
&, ;nbs, p; End If
Set fout = fso.Createtextfile(server.mappath(filepath),true)
fout.writeline HtmlContent
fout.close
set fso=nothing
Set fso = Server.CreateObject("Scripting.FileSystemObject")
If fso.fileexists(Server.MapPath(filepath)) Then
Response.Write "文件"&HtmlFilename&"已生成! "
Else
'Response.Write Server.MapPath(filepath)
Response.Write "文件"&HtmlFilename&"未生成! "
End If
Set fso = nothing
End function

'**************************************************
'函数名：Htmldel
'作用：使用FSO删除文件
'参数：HtmlFolder ----路径
' HtmlFilename ----文件名
'**************************************************
Sub Htmldel(HtmlFolder,HtmlFilename)
dim filepath,fso
filepath = HtmlFolder&"/"&HtmlFilename
Set fso = CreateObject("Scripting.FileSystemObject")
fso.DeleteFile(Server.mappath(filepath))
Set fso = nothing
Set fso = Server.CreateObject("Scripting.FileSystemObject")
If fso.fileexists(Server.MapPath(filepath)) Then
Response.Write "文件"&HtmlFilename&"未删除! "
Else
'Response.Write Server.MapPath(filepath)
Response.Write "文件"&HtmlFilename&"已删除! "
End If
Set fso = nothing
End Sub

'=================================================
'过程名：HTMLEncode
'作用：过滤HTML格式
'参数：fString ----转换内容
'=================================================
function HTMLEncode(ByVal fString)
If IsNull(fString)=False or fString<>"" or fString<>"$False$" Then
fString = Replace(fString, ">", ">")
fString = Replace(fString, "<", "<")
fString = Replace(fString, Chr(32), " ")
fString = Replace(fString, Chr(9), " ")
fString = Replace(fString, Chr(34), """)
fString = Replace(fString, Chr(39), "'")
fString = Replace(fString, Chr(13), "")
fString = Replace(fString, " ", " ")
fString = Replace(fString, CHR(10) & CHR(10), "")
fString = Replace(fString, Chr(10), " ")
HTMLEncode = fString
else
HTMLEncode = "$False$"
end if
end function

'=================================================
'过程名：unHTMLEncode
'作用：还原HTML格式
'参数：fString ----转换内容
'=================================================
function unHTMLEncode(ByVal fString)
If IsNull(fString)=False or fString<>"" or fString<>"$False$" Then
fString = Replace(fString, ">", ">")
fString = Replace(fString, "<", "<")
fString = Replace(fString, " ", Chr(32))
fString = Replace(fString, """, Chr(34))
fString = Replace(fString, "'", Chr(39))
fString = Replace(fString, "", Chr(13))
fString = Replace(fString, " ", " ")
fString = Replace(fString, "" , CHR(10) & CHR(10))
fString = Replace(fString, " ", Chr(10))
unHTMLEncode = fString
else
unHTMLEncode = "$False$"
end if
end function

function unhtmllist(content)
unhtmllist=content
if content <> "" then
unhtmllist=replace(unhtmllist,"'","";")
unhtmllist=replace(unhtmllist,chr(10),"")
unHtmllist=replace(unHtmllist,chr(13)," ")
end if
end function

function unhtmllists(content)
unhtmllists=content
if content <> "" then
unhtmllists=replace(unhtmllists,"""",""")
unhtmllists=replace(unhtmllists,"'",""")
unhtmllists=replace(unhtmllists,chr(10),"")
unHtmllists=replace(unHtmllists,chr(13)," ")
end if
end function

function htmllists(content)
htmllists=content
if content <> "" then
htmllists=replace(htmllists,"‘'","""")
htmllists=replace(htmllists,""","'")
htmllists=replace(htmllists," ",chr(13)&chr(10))
end if
end function

function uhtmllists(content)
uhtmllists=content
if content <> "" then
uhtmllists=replace(uhtmllists,"""","‘'")
uhtmllists=replace(uhtmllists,"'","";")
uhtmllists=replace(uhtmllists,chr(10),"")
uHtmllists=replace(uHtmllists,chr(13)," ")
end if
end function

'=================================================
'过程： Sleep
'功能：程序在此晢停几秒
'参数： iSeconds 要暂停的秒数
'=================================================
Sub Sleep(iSeconds)
response.Write "开始暂停 "&iSeconds&" 秒 "
Dim t:t=Timer()
While(Timer()<t+iSeconds)
'Do Nothing
Wend
response.Write "暂停 "&iSeconds&" 秒结束 "
End Sub

'==================================================
'函数名：MyArray
'作用：提取标签，以分隔
'参数：ConStr ------提取地址的原字符
'==================================================
Function MyArray(Byval ConStr)
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "({).+?(})"
Set Matches =objRegExp.Execute(ConStr)
For Each Match in Matches
TempStr=TempStr & "" & Match.Value
Next
Set Matches=nothing

TempStr=Right(TempStr,Len(TempStr)-1)
objRegExp.Pattern ="{"
TempStr=objRegExp.Replace(TempStr,"")
objRegExp.Pattern ="}"
TempStr=objRegExp.Replace(TempStr,"")
Set objRegExp=nothing
Set Matches=nothing

TempStr=Replace(TempStr,"$","")

If TempStr="" then
MyArray="在代码中没有可提取的东西"
Else
MyArray=TempStr
End if
End Function

'==================================================
'函数名：randm
'作用：产生6位随机数
'==================================================
Function randm
randomize
randm=Int((900000*rnd)+100000)
End Function
%>

内容总结

以上是互联网集市为您收集整理的一个带采集远程文章内容,保存图片,生成文件等完整的采集功能全部内容，希望文章能够帮你解决一个带采集远程文章内容,保存图片,生成文件等完整的采集功能所遇到的程序开发问题。如果觉得互联网集市技术教程内容还不错，欢迎将互联网集市网站推荐给程序员好友。

内容备注

版权声明：本文内容由互联网用户自发贡献，该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务，不拥有所有权，不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容，请发送邮件至 gblab@vip.qq.com 举报，一经查实，本站将立刻删除。

内容手机端

扫描二维码推送至手机访问。

本文链接：https://qyyshop.com/info/384203.html

来源：【匿名】

首页 / ASP / 一个带采集远程文章内容,保存图片,生成文件等完整的采集功能

一个带采集远程文章内容,保存图片,生成文件等完整的采集功能

内容导读

内容图文

内容总结

内容备注

内容手机端

【一个带采集远程文章内容,保存图片,生成文件等完整的采集功能】教程文章相关的互联网学习教程文章

信息收集【采集点OWASP CHINA】网址http://www.owasp.org.cn/

发一个采集(小偷)用的类，ASP+缓存实现【图】

创力采集程序用到的函数推荐第1/3页

利用MSXML2.XmlHttp和Adodb.Stream采集图片

phpcurl采集含__EVENTVALIDATION的asp网页【图】

asp只采集网站可见文本的正则

asp采集HTML内容常用代码,详讲正则采集

ASP 自动采集实现代码

ASP读取XML实例优酷专辑采集程序雷锋版

asp动态页面防采集的新方法

asp 采集程序常用函数分析

ASP实现防止网站被采集代码

asp 小偷采集程序原理与常用函数方法

防止网站被采集的理论分析以及十条方法对策第1/2页

一个带采集远程文章内容,保存图片,生成文件等完整的采集功能

采集 - 相关标签

功能 - 相关标签

文件 - 相关标签

ASP - 技术教程分类

ASP - 最新教程

ASP - 最热教程