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