采集的源码（转贴）

zhang_xxx398 · 发表于 2009-11-26 15:10

采集的源码.
2008-12-30 21:27

<%'定义xmlhttp
function GetXmlText(Url)
dim GetXmlHttp
set GetXmlHttp=server.Createobject("microsoft.XMLHTTP")
GetXmlHttp.open "Get",url,false,"",""
GetXmlHttp.Send
'GetXmlText=GetXmlHttp.Responsetext
GetXmlText=GetXmlHttp.ResponseBody
set GetXmlHttp=nothing
end function
'转换为字符
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 = nothing
End Function

'函数名：GetArray
'作用：提取链接地址，以$Array$分隔
'参数：ConStr ------提取地址的原字符
'参数：StartStr ------开始字符串
'参数：OverStr ------结束字符串
'参数：IncluL ------是否包含StartStr
'参数：IncluR ------是否包含OverStr
'==================================================
Function GetArray(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
on error resume next
If ConStr="$False$" or ConStr="" Or IsNull(ConStr)=True or StartStr="" Or OverStr="" or IsNull(StartStr)=True Or IsNull(OverStr)=True Then
   GetArray="没有搜索到你想要的..."
   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="没有搜索到你想要的..."
   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="没有搜索到你想要的..."
Else
   GetArray=TempStr
End if
End Function
'========================
'函数名：ReplaceTrim
'作用：过滤掉字符中所有的tab和回车和换行.
'参数：strContent 传入的内容
'========================
Function ReplaceTrim(ByVal strContent)
      On Error Resume Next
      Dim re
      Set re = New RegExp
      re.IgnoreCase = True
      re.Global = True
      re.Pattern = "(" & Chr(8) & "|" & Chr(9) & "|" & Chr(10) & "|" & Chr(13) & ")"
      strContent = re.Replace(strContent, vbNullString)
      Set re = Nothing
      ReplaceTrim = strContent
      Exit Function
End Function
'=========================================================
'** 函数：RemoveHref
'** 作用：正则表达式去除字符串中所有的超级链接
'=========================================================
Function RemoveHref(HTMLstr,ft)
Set ra = New RegExp
ra.IgnoreCase = True
ra.Global = True
ra.Pattern = "<a[^>]+>(.+?)<\/a>"
TtSTR= ra.replace(HTMLstr,"<a href=?q1=$1&ft="&ft&">$1</a>")
'Set Matches =ra.Execute(ConStr)
'For Each Match in Matches
' RemoveHref=RemoveHref&Match.value
'Next
RemoveHref=TtSTR
'RemoveHref="<a href=?q1="&TtSTR&"&ft="&ft&">"&TtSTR&"</a>"
End Function
%>

给大家分享。

anjjgn · 发表于 2011-7-31 23:00

仔细研究下

[资料] 采集的源码（转贴）

活跃勋章

斑竹勋章

宣传勋章

优秀斑主

地信元老

爱心勋章

组织勋章