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加水平滾動條
k = k + 1
End If
i = i + 1
Wend
Label1.Caption = "本網(wǎng)頁共有超級連接：" & k & " 個"
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
添加一個Listbox控件(用于存放讀出的網(wǎng)址)命名為(listurl),個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 "當前頁面沒有鏈接", 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 "未知錯誤", vbCritical, "錯誤"
End Sub
Private Sub Cmdstart_Click()
WebBrowser1.Navigate2 txtSearch.Text
End Sub
5.VB獲得指定網(wǎng)頁里面的圖片和連接地址
Option Explicit
'首先在工程中加入對Microsoft Internet Controls的引用
'指定瀏覽器對象的Document
Private mDocument As Object
Private Sub Command2_Click()
On Error Resume Next
DoEvents
mComGetIEWindows "zcsor的專欄" '給初學者: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 '輸出每個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)頁標題
Private Sub mComGetIEWindows(ByVal IETitle As String)
'瀏覽器對象集合(包含IE也包含資源管理器)
Dim mShellWindow As New SHDocVw.ShellWindows
'循環(huán)變量
Dim mIndex As Long
'從第一個瀏覽器對象循環(huán)到最后一個
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 '如果是指定窗口(用窗口標題判斷的,其他也可以,例如URL)
Set mDocument = mShellWindow.Item(mIndex).Document '鎖定我們要的瀏覽器對象
Exit Sub
End If
End If
Next mIndex
End Sub
==============================================================================================
1.VB判斷哪些字段具有超鏈接并把該超鏈接提取出來
'主要先取 <a href 和 </a> 這兩段間的數(shù)據(jù) 然后再分離
'=================================
'留個名
'給一個我自己用來分析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>實體內容</b>尾部后"
sourceStr = vSourceStr
sStr = vsStr
eStr = veStr
Select Case vFunType
Case 0 '實體內容
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>實體內容</b>
sourceStr = FindStr(sourceStr, 0, sStr, eStr)
FindStr = sStr & sourceStr & eStr
'**********************
Case 2 '<b>實體內容
sourceStr = FindStr(sourceStr, 0, sStr, eStr)
FindStr = sStr & sourceStr
'**********************
Case 3 '實體內容</b>
sourceStr = FindStr(sourceStr, 0, sStr, eStr)
FindStr = sourceStr & eStr
'**********************
Case 4 '頭部前<b>實體內容</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>實體內容
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>實體內容</b>尾部后
s = InStr(sourceStr, sStr)
If s <> 0 Then
FindStr = Mid$(sourceStr, s)
Else
FindStr = ""
End If
'**********************
Case 7 '實體內容</b>尾部后
s = InStr(sourceStr, sStr)
If s <> 0 Then
FindStr = Mid$(sourceStr, s + Len(sStr))
Else
FindStr = ""
End If
'**********************
Case 8 '1 多項結果返回 遞歸調用循環(huán)返回用$分隔的多項結果 主要用于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 ......>標記,則提取其超鏈接(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
====================================================================================================
'text1(0-1),command2(0-2)
Dim isGoUrl As Boolean
Private Sub Command1_Click()
Command1.Enabled = False
WebBrowser1.Navigate Combo1.Text
isGoUrl = True
End Sub
Private Sub Command2_Click(Index As Integer)
Dim doc As IHTMLDocument2, C
Set doc = WebBrowser1.Document
On Error Resume Next
Label1.Tag = 0
If Index = 0 Then
For Each C In doc.links
If Trim$(C.innerText) = Trim$(Text1(0).Text) Then
Label1.Caption = C.href
Label1.Tag = 1
Label2.Caption = "連接已找到，點擊可以瀏覽"
Exit For
End If
Next
ElseIf Index = 1 Then
For Each C In doc.links
If InStr(1, Trim$(C.href), Trim$(Text1(1).Text)) > 0 Then
Label1.Caption = C.href
Label1.Tag = 1
Label2.Caption = "連接已找到，點擊可以瀏覽"
Exit For
End If
Next
ElseIf Index = 2 Then
RichTextBox1.Text = "查找結果：" & vbCrLf
RichTextBox1.SelStart = Len(RichTextBox1.Text)
For Each C In doc.links
If InStr(1, Trim$(C.href), Trim$(Text1(1).Text)) > 0 Then
RichTextBox1.SelText = "-------------------" & vbCrLf
RichTextBox1.SelText = C.href & vbCrLf
Label1.Tag = Label1.Tag + 1
End If
Next
If Label1.Tag > 0 Then
RichTextBox1.SelText = "-------------------" & vbCrLf
RichTextBox1.SelText = "一共找到" & Label1.Tag & "個符合條件的連接！"
Else
RichTextBox1.SelText = "沒有找到符合條件的連接！"
End If
End If
If Label1.Tag = 0 Then
With Label1
.Caption = "沒有找到指定的連接"
.Font.Underline = False
.ForeColor = vbRed
.MousePointer = 0
End With
Label2.Caption = ""
Else
With Label1
.Font.Underline = True
.ForeColor = vbBlue
.MousePointer = 99
End With
End If
End Sub
Private Sub Form_Load()
WebBrowser1.Navigate "about:blank"
isGoUrl = False
End Sub
Private Sub Label1_Click()
On Error GoTo e2
If Label1.Tag = 1 Then
WebBrowser1.Navigate Label1.Caption
End If
e2:
End Sub
Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
If Not (pDisp Is WebBrowser1.Object) Then Exit Sub
If isGoUrl = True And (URL = Combo1.Text Or URL = Combo1.Text & "/") Then
GetHtml
Command1.Enabled = True
End If
End Sub
Sub GetHtml()
Dim doc As IHTMLDocument2, C
Set doc = WebBrowser1.Document
On Error Resume Next
RichTextBox1.Text = ""
RichTextBox1.SelText = "=======================================" & vbCrLf
RichTextBox1.SelText = "一共有 " & doc.links.length & " 個超鏈接" & vbCrLf
RichTextBox1.SelText = "=======================================" & vbCrLf
For Each C In doc.links
RichTextBox1.SelText = C.innerText & " [" & C.href & "]" & vbCrLf
Next
End Sub
=============================================================================================
Dim isGoUrl As Boolean
Private Sub Command1_Click()
Command1.Enabled = False
WebBrowser1.Navigate Combo1.Text
isGoUrl = True
End Sub
Private Sub Command2_Click()
Dim doc As IHTMLDocument2, C
Set doc = WebBrowser1.Document
On Error Resume Next
Label1.Tag = 0
For Each C In doc.links
If Trim$(C.innerText) = Trim$(Text1.Text) Then
Label1.Caption = C.href
Label1.Tag = 1
Label2.Caption = "點擊下面的連接在上面的窗口打開"
Exit For
End If
Next
If Label1.Tag = 0 Then
With Label1
.Caption = "沒有找到指定的連接"
.Font.Underline = False
.ForeColor = vbRed
.MousePointer = 0
End With
Label2.Caption = ""
Else
With Label1
.Font.Underline = True
.ForeColor = vbBlue
.MousePointer = 99
End With
End If
End Sub
Private Sub Form_Load()
WebBrowser1.Navigate "about:blank"
isGoUrl = False
End Sub
Private Sub Label1_Click()
On Error GoTo e2
If Label1.Tag = 1 Then
WebBrowser1.Navigate Label1.Caption
End If
e2:
End Sub
Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
If Not (pDisp Is WebBrowser1.Object) Then Exit Sub
If isGoUrl = True And (URL = Combo1.Text Or URL = Combo1.Text & "/") Then
GetHtml
Command1.Enabled = True
End If
End Sub
Sub GetHtml()
Dim doc As IHTMLDocument2, C
Set doc = WebBrowser1.Document
On Error Resume Next
RichTextBox1.Text = ""
RichTextBox1.SelText = "=======================================" & vbCrLf
RichTextBox1.SelText = "一共有 " & doc.links.length & " 個超鏈接" & vbCrLf
RichTextBox1.SelText = "=======================================" & vbCrLf
For Each C In doc.links
RichTextBox1.SelText = C.innerText & " [" & C.href & "]" & vbCrLf
Next
End Sub
================================================================================================
提取圖片鏈接
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Private Sub GetLinks()
Dim L As Integer
Dim i As Integer
Dim Varl As Variant
Set Doc = WebBrowser1.Document
Set All = Doc.images '取圖片的連接
L = All.length
For i = 0 To L - 1
Set Varl = All.Item(i, varempty)
Text1.Text = Text1.Text & vbCrLf & Varl.href & vbCrLf
Set Varl = Nothing
Next i
Set All = Nothing
Set Doc = Nothing
End Sub
Private Sub Cmd_get_Click()
If Txt_url = "" Then
MsgBox "先輸入網(wǎng)址,不要那么著急"
Exit Sub
End If
GetLinks
End Sub
Private Sub Cmd_load_Click()
A = Txt_url.Text
If Left(A, 7) <> "http://" Then '判斷連接前是否有"http://"字符串
Text1.Text = "http://" & Txt_url.Text
End If
Text1 = ""
If Txt_url = "" Then
MsgBox "沒輸入網(wǎng)地"
Exit Sub
End If
WebBrowser1.Navigate Txt_url.Text
Lab_Tip.Caption = "網(wǎng)地加載完成,請點擊提取圖片按鈕......"
End Sub
Private Sub Command3_Click()
dhk.CancelError = False
dhk.ShowSave
save = dhk.FileName
Open save For Output As #1
Print #1, Text1
Close #1
MsgBox "輸出成功", vbOKOnly, "恭喜！" '輸出結果
Lab_Tip.Caption = "請自行添加注釋"
End Sub
聯(lián)系客服
