VB+XMLHTTP即时获取网页源码

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

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