VB+XMLHTTP即时获取网页源码

wq1282

已于 2023-03-01 09:55:29 修改

阅读量7.2k

点赞数 2

CC 4.0 BY-SA版权

分类专栏： VB源码文章标签： vb webbrowser function string url web

于 2010-10-11 20:46:00 首次发布

原文链接：http://zhidao.baidu.com/question/59283660.html

VB源码专栏收录该内容

45 篇文章

订阅专栏

本文介绍了一种使用VBA进行网络请求的方法，并通过定时器实现定时获取网页内容的功能。详细展示了如何创建XMLHTTP对象来发送GET请求，解析响应结果，并通过定时器每秒更新显示从指定网址获取的时间信息。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

添加一个时钟控件，运行后就可以在立即窗口看到调试信息。

Option Explicit

Function GetBody(Url)
	Dim ObjXML
	Set ObjXML = CreateObject("Microsoft.XMLHTTP")
	With ObjXML
		.Open "Get", Url, False, "", ""
		.SEnd
		GetBody = .ResponseBody
	End With
	GetBody = BytesToBstr(GetBody, "UTF-8")
	Set ObjXML = Nothing
End Function
  
Function BytesToBstr(strBody, CodeBase)
	Dim ObjStream
	Set ObjStream = CreateObject("Adodb.Stream")
	With ObjStream
		.Type = 1
		.Mode = 3
		.Open
		.Write strBody
		.Position = 0
		.Type = 2
		.Charset = CodeBase
		BytesToBstr = .ReadText
		.Close
	End With
	Set ObjStream = Nothing
End Function

Private Sub Form_Load()
    Timer1.Interval = 1000
End Sub

Private Sub Timer1_Timer()
	Dim strHTML As String
	strHTML = GetBody("http://www.cdcgames.net/GetTime/Default.aspx")
	Debug.Print strHTML
End Sub

Option Explicit
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Private Function GetWebCodesDL(WebUrl As String) As String
On Error Resume Next
    If WebUrl = "" Then Exit Function
    Dim TempFile$
    TempFile = App.Path & "/DownTemp.html"
'下载文件
    URLDownloadToFile 0, WebUrl, TempFile, 0, 0
'读取内容
    If Dir(TempFile) <> "" Then
        Open TempFile For Input As #1
            Input #1, GetWebCodesDL
        Close #1
        Kill TempFile
    End If
End Function


Function GetWebCodes(WebUrl As String) As String
On Error Resume Next
    If WebUrl = "" Then Exit Function
    Dim xmlHTTP1
    Set xmlHTTP1 = CreateObject("Microsoft.XMLHTTP")
    xmlHTTP1.Open "get", WebUrl, True
    xmlHTTP1.SEnd
    While xmlHTTP1.ReadyState <> 4
        DoEvents
    Wend
    GetWebCodes = xmlHTTP1.responseText
    Set xmlHTTP1 = Nothing
End Function


Function GetHtmlCodes(ByRef WebBrowser As WebBrowser, ByRef WebUrl As String) As String
On Error Resume Next
    If WebUrl = "" Then Exit Function
    WebBrowser.Navigate WebUrl
    While WebBrowser.ReadyState <> 4
        DoEvents
    Wend
    GetHtmlCodes = WebBrowser.Document.documentElement.Outertext
End Function


'Function GetHtmlCodes(WebBrowser As WebBrowser, WebUrl As String) As String
'    If WebUrl = "" Then Exit Function
'    Dim web1
'    Set web1 = Form1.Controls.Add("SHELL.EXPLORER.2", "web1")
'    web1.Visible = True
'    web1.Move 0, 0, 15, 15
'    web1.Navigate WebUrl
'    While web1.ReadyState <> 4
'        DoEvents
'    Wend
'    GetHtmlCodes = web1.Document.documentElement.Outertext
'    Set web1 = Nothing
'End Function
''Me.Controls.Add("SHELL.EXPLORER.2", "web1", Me)



Function GetBodyCodes(Url)
On Error Resume Next
    Url = Url & "?rNum=" & Int((9999) * Rnd(Now()) + 1)
    Dim ObjXML
    Set ObjXML = CreateObject("Microsoft.XMLHTTP")
    With ObjXML
        .Open "Get", Url, False, "", ""
        .SEnd
        GetBodyCodes = .ResponseBody
    End With
    GetBodyCodes = BytesToBstr(GetBodyCodes, "UTF-8")
    Set ObjXML = Nothing
End Function

Function BytesToBstr(strBody, CodeBase)
    Dim ObjStream
    Set ObjStream = CreateObject("Adodb.Stream")
    With ObjStream
        .Type = 1
        .Mode = 3
        .Open
        .Write strBody
        .Position = 0
        .Type = 2
        .Charset = CodeBase
        BytesToBstr = .ReadText
        .Close
    End With
    Set ObjStream = Nothing
End Function

Function GetBodyCodes2(Url)
On Error Resume Next
    Url = Url & "&rNum=" & Int((9999) * Rnd(Now()) + 1) '''&&&&????
    Dim ObjXML
    Set ObjXML = CreateObject("Microsoft.XMLHTTP")
    With ObjXML
        .Open "Get", Url, False, "", ""
        .SEnd
        GetBodyCodes2 = .ResponseBody
    End With
    GetBodyCodes2 = BytesToBstr(GetBodyCodes2, "gb2312")
    Set ObjXML = Nothing
End Function

http://zhidao.baidu.com/question/40057444.html

http://zhidao.baidu.com/question/59283660.html