1.

Private Sub Command1_Click()
Dim aa As String
Dim i As Integer
Dim s As String
s = "question"
fname = "C:\TDDOWNLOAD\a.txt"

Open fname For Input As #1
Do Until EOF(1)
Line Input #1, aa
List1.AddItem aa, i
i = i + 1
Loop
Close #1

For i = 0 To List1.ListCount - 1
If InStr(1, List1.List(i), s) > 0 Then
List2.AddItem List1.List(i)
End If
Next
Kill "C:\TDDOWNLOAD\a.txt"
End Sub

Private Sub Command2_Click()
Dim s As String
s = "question"
For i = 0 To List1.ListCount - 1
If InStr(1, List1.List(i), s) > 0 Then
List2.AddItem List1.List(i)
End If
Next

End Sub

Private Sub Form_Load()
WebBrowser1.Navigate "http://zhidao.baidu.com/browse/867"
End Sub

Private Sub List2_DblClick()
    Form2.Show
    Form2.WebBrowser1.Navigate Me.List1.List(Me.List1.ListIndex)
End Sub

Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
Dim Document, i, s1, s2
Open "C:\TDDOWNLOAD\a.txt" For Output As #1
For i = 0 To WebBrowser1.Document.links.length - 1
s1 = WebBrowser1.Document.links(i).href
s2 = WebBrowser1.Document.links(i).innertext
Print #1, s1 & "," & s2
Next
Close #1
End Sub

===========================================================================================

Private Sub Form_Load()

WebBrowser1.Navigate "http://zhidao.baidu.com/browse/867"
End Sub

Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
Dim Document, i, s1, s2
For i = 0 To WebBrowser1.Document.links.length - 1
s1 = WebBrowser1.Document.links(i).href
s2 = WebBrowser1.Document.links(i).innertext
List1.AddItem s2 & " : " & s1
Next
End Sub

.................

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
    (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
    lParam As Any) As Long
Const LB_SETHORIZONTALEXTENT = &H194

Private Sub Form_Load()
  WebBrowser1.Navigate "http://zhidao.baidu.com/browse/867"
End Sub
Private Sub Command1_Click()
  Dim TagName, str As String
  Dim count, i, k As Integer
  Dim cols
  List1.Clear
  Set cols = WebBrowser1.Document.All
  count = cols.length
  k = 0
  While i < count
    TagName = cols.Item(i).TagName
    If TagName = "A" Or TagName = "IMG" Then  '查找超鏈接和img圖形
        str = k & "  " & TagName & "... " & cols.Item(i).href
        List1.AddItem (str)       '增加超鏈接
        SendMessage List1.hwnd, LB_SETHORIZONTALEXTENT, Me.TextWidth(str), ByVal 0&  '為list加水平滾動(dòng)條
        k = k + 1
    End If
    i = i + 1
  Wend
  Label1.Caption = "本網(wǎng)頁共有超級(jí)連接：" & k & "  個(gè)"
End Sub

============================================================================================

2.

'下載好網(wǎng)頁
Private Sub Command3_Click()
Dim fso, ts, re
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.OpenTextFile("d:\百度知道_VB_全部問題.htm")
s = ts.ReadAll
ts.Close
Set re = CreateObject("VBScript.RegExp")
re.IgnoreCase = True
re.Global = True
re.Pattern = "<a[\s ]+href ?= ?[""'](.*?)[""']"
For Each i In re.Execute(s)
Debug.Print i.submatches(0)
Next
End Sub

3.

Private Sub aa_Load()
Dim XXX As Long
Dim Text As String, Temp As String
Dim A As Long, X As Long, aa As Integer
Dim N As Long
Dim TextA As String

Const Xpath = "G:\MM\桌面\c\" '文件目錄
Const OutPath = "G:\MM\桌面/3.txt" '輸出文件目錄及文件名
Const FindType = ".jpg" '圖片類型
Const FindSer = "http:" '查找字符串類型

File1.Path = Xpath
X = 0: XXX = 0
Open OutPath For Output As #2
For aa = 0 To File1.ListCount - 1
Open Xpath & File1.List(aa) For Input As #1
DoEvents
Me.Caption = aa & " " & XXX
Text = ""
Do While Not EOF(1)
Line Input #1, Temp
Text = Text & Temp
Loop
N = 0
X = 0
Do
A = InStr(X + 1, Text, FindType)
If A = 0 Then Exit Do
If A <> 0 Then
For i = 1 To 255
Temp = Mid(Text, A - i, 5)
If Temp = FindSer Then
TextA = Mid(Text, A - i, i + 4)
Print #2, "<a href=" & """" & TextA & """" & ">OK</a>"
XXX = XXX + 1
X = A
Exit For
End If
Next i
End If
N = N + 1
Loop Until N > 50
Close #1
Next aa
Close #2
MsgBox XXX
End Sub
Private Sub Command1_Click()
aa_Load
End Sub

4.

加入webbrowser和scriptlet控件(引用部件Microsoft HTMl object Library

添加一個(gè)Listbox控件(用于存放讀出的網(wǎng)址)命名為(listurl),個(gè)textbox()控件用于打開網(wǎng)址命名為txtsearch

Option Explicit
Dim UrlNow As IHTMLDocument2
Private Sub CmdGeturl_Click()
      'WebBrowser1.Stop
      'Dim UrlNow
      On Error GoTo errordes
      Set UrlNow = WebBrowser1.Document
      If UrlNow Is Nothing Then
          MsgBox "當(dāng)前頁面沒有鏈接", vbInformation, "注意"
      Else
          Dim UrlIndex As Long
          For UrlIndex = 0 To UrlNow.links.length - 1
              ListUrl.AddItem UrlNow.links(UrlIndex)
          Next UrlIndex
      End If
      Exit Sub
errordes:
      MsgBox "未知錯(cuò)誤", vbCritical, "錯(cuò)誤"
    
End Sub

Private Sub Cmdstart_Click()
      WebBrowser1.Navigate2 txtSearch.Text

End Sub

5.VB獲得指定網(wǎng)頁里面的圖片和連接地址

Option Explicit

'首先在工程中加入對(duì)Microsoft Internet Controls的引用
'指定瀏覽器對(duì)象的Document
Private mDocument As Object
Private Sub Command2_Click()
On Error Resume Next
DoEvents
mComGetIEWindows "zcsor的專欄" '給初學(xué)者:VB如何操作WEB頁的瀏覽提交———八：獲取網(wǎng)頁上的鏈接、圖片指向地址"
If mDocument Is Nothing Then
     MsgBox  "未打開指定頁"
Else
     Dim mIndex As Long, mIndexEx As Long
     For mIndex = 0 To mDocument.Forms.length - 1        '輸出每個(gè)FORM
         Print mDocument.Forms(mIndex).Name
         lstLinks.AddItem  "輸出連接"
         For mIndexEx = 0 To mDocument.links.length - 1  '輸出連接
             lstLinks.AddItem mDocument.links(mIndexEx)
         Next
         lstLinks.AddItem  "圖片地址"
         For mIndexEx = 0 To mDocument.images.length - 1  '輸出圖片
             lstLinks.AddItem mDocument.images(mIndexEx).src      '圖片地址
         Next
     Next
     Text1.Text = mDocument.documentElement.innerHTML
End If
End Sub

'參數(shù)為網(wǎng)頁標(biāo)題
Private Sub mComGetIEWindows(ByVal IETitle As String)
'瀏覽器對(duì)象集合(包含IE也包含資源管理器)
Dim mShellWindow As New SHDocVw.ShellWindows
'循環(huán)變量
Dim mIndex As Long
'從第一個(gè)瀏覽器對(duì)象循環(huán)到最后一個(gè)
For mIndex = 0 To mShellWindow.Count - 1
     If VBA.TypeName(mShellWindow.Item(mIndex).Document) =  "HTMLDocument" Then   '如果是IE窗口而不是資源管理器
         If mShellWindow.Item(mIndex).Document.Title = IETitle Then  '如果是指定窗口(用窗口標(biāo)題判斷的,其他也可以,例如URL)
             Set mDocument = mShellWindow.Item(mIndex).Document  '鎖定我們要的瀏覽器對(duì)象
             Exit Sub
         End If
     End If
Next mIndex
End Sub

==============================================================================================

1.VB判斷哪些字段具有超鏈接并把該超鏈接提取出來

'主要先取 <a href 和 </a> 這兩段間的數(shù)據(jù) 然后再分離

'=================================

'留個(gè)名
'給一個(gè)我自己用來分析HTML源碼的函數(shù)你

'*************************************************************************
'**函 數(shù) 名：FindStr
'**中文意譯:
'**輸 入：ByVal vSourceStr(String) -
'** ：ByVal vFunType(Integer) -
'** ：Optional ByVal vsStr(String) -
'** ：Optional ByVal veStr(String) -
'**輸 出：(String) -
'**功能描述：
'** :
'**作 者：秋色烽火
'**日 期：2007-11-20 22:02:05
'*************************************************************************
Public Function FindStr(ByVal vSourceStr As String, ByVal vFunType As Integer, Optional ByVal vsStr As String, Optional ByVal veStr As String) As String
Dim sourceStr, sourceStrtemp, sourceStrtemp2, sStr, eStr, s, E, opStr
'"頭部前<b>實(shí)體內(nèi)容</b>尾部后"
sourceStr = vSourceStr
sStr = vsStr
eStr = veStr
Select Case vFunType
Case 0 '實(shí)體內(nèi)容
s = InStr(sourceStr, sStr)
If s <> 0 Then
sourceStr = Mid$(sourceStr, s + Len(sStr))
E = InStr(sourceStr, eStr)
If E <> 0 Then
FindStr = Mid$(sourceStr, 1, E - 1)
Else
FindStr = ""
End If
End If
'**********************
Case 1 '<b>實(shí)體內(nèi)容</b>
sourceStr = FindStr(sourceStr, 0, sStr, eStr)
FindStr = sStr & sourceStr & eStr
'**********************
Case 2 '<b>實(shí)體內(nèi)容
sourceStr = FindStr(sourceStr, 0, sStr, eStr)
FindStr = sStr & sourceStr
'**********************
Case 3 '實(shí)體內(nèi)容</b>
sourceStr = FindStr(sourceStr, 0, sStr, eStr)
FindStr = sourceStr & eStr
'**********************
Case 4 '頭部前<b>實(shí)體內(nèi)容</b>
E = InStr(sourceStr, sStr)
If E <> 0 Then
FindStr = Mid$(sourceStr, 1, E - 1) & FindStr(sourceStr, 1, sStr, eStr)
Else
FindStr = ""
End If
'**********************
Case 5 '頭部前<b>實(shí)體內(nèi)容
E = InStr(sourceStr, sStr)
If E <> 0 Then
FindStr = Mid$(sourceStr, 1, E - 1) & FindStr(sourceStr, 2, sStr, eStr)
Else
FindStr = ""
End If
'**********************
Case 6 '<b>實(shí)體內(nèi)容</b>尾部后
s = InStr(sourceStr, sStr)
If s <> 0 Then
FindStr = Mid$(sourceStr, s)
Else
FindStr = ""
End If
'**********************
Case 7 '實(shí)體內(nèi)容</b>尾部后
s = InStr(sourceStr, sStr)
If s <> 0 Then
FindStr = Mid$(sourceStr, s + Len(sStr))
Else
FindStr = ""
End If
'**********************
Case 8 '1 多項(xiàng)結(jié)果返回 遞歸調(diào)用循環(huán)返回用$分隔的多項(xiàng)結(jié)果 主要用于split侵害
sourceStrtemp = FindStr(sourceStr, 7, sStr, eStr)
Do While sourceStrtemp <> ""
E = InStr(sourceStrtemp, eStr)
If E <> 0 Then
opStr = opStr & "$$" & Mid$(sourceStrtemp, 1, E - 1)
sourceStrtemp = FindStr(Mid$(sourceStrtemp, E + Len(eStr)), 7, sStr, eStr)
End If
Loop
FindStr = opStr
'**********************
Case 9 '從右向左匹配字符串
' For i = Len(sourceStr) To 1 Step -1
' sourceStrtemp = sourceStrtemp & Mid$(sourceStr, i, 1)
' Next
' DoEvents
' For i = Len(sStr) To 1 Step -1
' sourceStrtemp2 = sourceStrtemp2 & Mid$(sStr, i, 1)
' Next
' DoEvents
sourceStrtemp = StrReverse(sourceStr)
sourceStrtemp2 = StrReverse(sStr)
s = InStr(sourceStrtemp, sourceStrtemp2)
If s <> 0 Then
sourceStrtemp = Mid$(sourceStrtemp, 1, s - 1)
sourceStrtemp2 = ""
For i = Len(sourceStrtemp) To 1 Step -1
sourceStrtemp2 = sourceStrtemp2 & Mid$(sourceStrtemp, i, 1)
Next
DoEvents
FindStr = sourceStrtemp2
Else
FindStr = ""
End If
End Select
End Function

2.

Private Sub Command1_Click()
For i = 0 To WebBrowser1.Document.All.length - 1
'如果是<A ......>標(biāo)記,則提取其超鏈接(href)及<A>與</A>間的文本
If UCase(WebBrowser1.Document.All(i).tagname) = "A" Then
Text1.Text = Text1.Text & WebBrowser1.Document.All(i).outertext & ":" & WebBrowser1.Document.All(i).href & vbCrLf
End If
Next i
End Sub

Private Sub Form_Load()
Command1.Caption = "提取超鏈接"
WebBrowser1.Navigate "http://zhidao.baidu.com/browse/867"
End Sub

====================================================================================================