VB 如何提取网页源带码中的url链接，动态添加控件实例

最新推荐文章于 2023-04-18 14:28:23 发布

jiutao_tang

最新推荐文章于 2023-04-18 14:28:23 发布

阅读量2.7k

点赞数

分类专栏： # VB 编程文章标签： url vb function integer string class

VB 编程专栏收录该内容

7 篇文章 0 订阅

订阅专栏

本人进行了简单修改，其提取链接的技术并不完美，无法处理复杂情况。着重学习其动态添加控件、为新控件添加事件处理的方法

新建一个工程，在Form1中添加如下代码

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 getHTTPPage(Url)
    Dim Http
    Set Http = CreateObject("MSXML2.XMLHTTP")
    Http.Open "GET", Url, False
    a = Http.send()
    If Http.readystate <> 4 Then
        Exit Function
    End If
    getHTTPPage = BytesToBstr(Http.responseBody, "GB2312")
    Set Http = Nothing
    If Err.Number <> 0 Then Err.Clear
End Function

Private Sub Form_Load()
    Dim Url, tempStr As String
    Dim a() As String
    Dim Label() As Object    '标签控件对象数组
    Dim clsT() As New Class1 '对象数组
    Url = InputBox("请输入一个网址")        '输入对话框
    a = Split(getHTTPPage(Url), "href=")    '获取页面源代码，并提取href
    Dim i As Integer
    Dim nTop As Long   '标签位置，上距
    ReDim Label(UBound(a) - 1) '重设动态数组大小
    ReDim clsT(UBound(a) - 1) '重设动态数组大小
    For i = 1 To UBound(a) - 1
        Set Label(i) = Controls.Add("VB.Label", "Label" & CStr(i)) '动态创建标签控件，CStr把i转换成字符串类型
        Label(i).Height = 300
        Label(i).Top = nTop
        Label(i).Visible = True
        tempStr = Split(a(i), ">")(0) '<a> 标签的结束
        tempStr = Replace(tempStr, CStr(Chr(34)), "")   '去除两边双引号
        If Left(tempStr, 4) <> "http" Then tempStr = Url & tempStr '左边没有http则可能是相对链接
        If InStr(tempStr, " ") Then tempStr = Split(tempStr, " ")(0) '用空格分离URL
        Label(i).Caption = tempStr
        Label(i).AutoSize = True
        nTop = nTop + 30 * 8
        clsT(i).Init Label(i) '标签类
    Next i
End Sub

然后新建一个类模块class1加入以下代码:
Option Explicit
Dim WithEvents L As Label

Public Sub Init(tmp As Label)
    Set L = tmp
End Sub

Private Sub L_Click()
    Shell "C:/Program Files/Internet Explorer/iexplore.exe " & L.Caption
End Sub

运行程序