VB抓取新浪视频内容

 '************************

'请尊重著作权，转载请注明出处。

'By wgscd

'Blog: http://blog.csdn.net/wgsnet

VB抓取新浪视频内容
Private Sub Command1_Click()
 Me.Text1.Text = GetHttpPage("http://you.video.sina.com.cn/c/22/mr/")

End Sub

 

Function GetHttpPage(HttpUrl)
   If IsNull(HttpUrl) = True Or HttpUrl = "$False$" Then
      GetHttpPage = "$False$"
      Exit Function
   End If
   Dim Http
   Set Http = CreateObject("MicroSoft.XMLHTTP")
   Http.Open "GET", HttpUrl, False
   Http.Send
 
   If Http.ReadyState <> 4 Then
 
      Set Http = Nothing
      GetHttpPage = "$False$"
      Exit Function
   End If
  
    If Http.Status = 404 Then '找不到页面
   
         'MsgBox "404"
           GetHttpPage = "$False$"
        Exit Function
     End If
    
   
   GetHttpPage = BytesToBstr(Http.responseBody, "GB2312")

   Set Http = Nothing
   If Err.Number <> 0 Then
      Err.Clear
   End If
  
  
End Function

Function BytesToBstr(Body, Cset)
   Dim Objstream
   Set Objstream = 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

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

Function ShowErr(ErrMsg)
response.Write "<script>alert('" & ErrMsg & "');history.back();</script>"
response.end
End Function

 

'-------------------------------------------------
'过程名：   RegUrl(TheStr)
'说明  ：   提取需要的HTML内容 'By wgcd
'返回类型：   string
'----------------------------------------------------
Function RegUrl(TheStr)
   Dim matchStr, strTemp
   Set regEx = New RegExp
   regEx.IgnoreCase = True
   regEx.Global = True '****这一句加上是全部替换，如果不加，只替换第一个
   regEx.Pattern = "(<li><img style=""cursor:pointer.*/></li>)"
  ' 把所有匹配的HTML代码放入Matches集合
  'dim str1
  'str1="<li><img style=""cursor:pointer; width:120px; height:90px"" alt="""
   Set Matches = regEx.Execute(TheStr)
  ' 显示所有匹配的HTML代码
      For Each Item In Matches
          List1.AddItem (Item.Value)
         matchStr = matchStr & Item.Value
         matchCount = matchCount + 1
      Next
   ' 显示其中一项
   ' List1.AddItem (Matches.Item(0).Value)
 
   matchStr = Replace(matchStr, "<li><img style=""cursor:pointer; width:120px; height:90px"" alt=""", vbNewLine)
   matchStr = Replace(matchStr, """ title=""", "|")
   matchStr = Replace(matchStr, """ οnclick=""window.open('/b/", "|http://www.showle.com/flvplayer.swf?auto=1&vid=")
   matchStr = regReplace(matchStr, "-.*html.*src=/""", "|") '正则表达式替换
   matchStr = Replace(matchStr, """ /></li>", "")
    List1.AddItem (matchStr)     '输出
   RegUrl = matchStr
End Function
'--------------------------------------------------------
  
  
'-------------------------------------------------
'过程名：   regReplace
'说明  ：    '正则表达式替换 By wgscd
'返回类型：   string
'----------------------------------------------------

Function regReplace(str, patrn, rStr)
Dim regEx
Set regEx = New RegExp
regEx.Pattern = patrn
regEx.Global = True
regReplace = regEx.Replace(str, rStr)
End Function

'----------------------------------------------------

'-------------------------------------------------
'过程名：   SaveToFile(ByVal strFileName,strContent)
'说明  ：    '保存文件 By wgcd
'参数  ：   strFileName 保存名字
'参数  ：   strContent  内容

'返回类型：   string
'----------------------------------------------------

Function SaveToFile(ByVal strFileName, strContent)
Set fso = CreateObject("Scripting.FileSystemObject")
Set hf = fso.CreateTextFile(Server.mappath(strFileName), True)
'hf.write vbcrlf
hf.Write strContent
hf.Close
Set hf = Nothing
Set fso = Nothing

End Function