'代码出处：http://blog.csdn.net/yao_yu_126/article/details/8539757
'方    法：工程 - 引用-Microsoft WinHTTP Services, version 5.1
'说    明：WinHttp可以伪造HTTP协议头，伪装成真正的浏览器来访问网页，从而得到更真实的数据，比XmlHTTP相比更加灵活一些(一般用XmlHTTP不行的话，WinHttp决对能搞定)
'注    意：每个网站的协议头都不一样，这得看抓包数据结果来决定该设置哪些协议头，有些网站不能加"User-Agent"这个文件头，否则不会返回结果

Private Sub Command1_Click() '模拟GET
    Dim WinHttp As WinHttp.WinHttpRequest '声明一个对象
    Set WinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
    WinHttp.Open "GET", "http://www.baidu.com/", True
    WinHttp.SetTimeouts 30000, 30000, 30000, 30000 '设置超时时间
    WinHttp.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = &H3300 '忽略错误
    WinHttp.SetRequestHeader "Connection", "keep-alive"
    WinHttp.SetRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,*/*;q=0.8"
    WinHttp.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/43.0.2357.134 Safari/537.36"
    WinHttp.Send            '发送
    WinHttp.WaitForResponse '异步发送
    
    Text1.Text = BytesToBstr(WinHttp.ResponseBody, "UTF-8")          '返回HTML(同样可用WinHttp.ResponseText返回HTML)
    Text2.Text = WinHttp.GetAllResponseHeaders                       '返回所有协议头
    
    Set WinHttp = Nothing
End Sub

Private Sub Command2_Click() '模拟POST
    Dim ShuJu As String
    Dim WinHttp As WinHttp.WinHttpRequest '声明一个对象
    Set WinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
    ShuJu = "name=abc,pass=123456" '设置POST数据
    WinHttp.Open "POST", "http://www.baidu.com/xxx", True
    WinHttp.SetTimeouts 30000, 30000, 30000, 30000 '设置超时时间
    WinHttp.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = &H3300 '忽略错误
    WinHttp.SetRequestHeader "Connection", "keep-alive"
    WinHttp.SetRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,*/*;q=0.8"
    WinHttp.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/43.0.2357.134 Safari/537.36"
    WinHttp.Send ShuJu       '发送
    WinHttp.WaitForResponse  '异步发送
    
    Text1.Text = BytesToBstr(WinHttp.ResponseBody, "UTF-8")          '返回HTML(同样可用WinHttp.ResponseText返回HTML)
    Text2.Text = WinHttp.GetAllResponseHeaders                       '返回所有协议头
    
    Set WinHttp = Nothing
End Sub

Public Function BytesToBstr(strBody, CodeBase) '编码转换("UTF-8"或者"GB2312"或者"GBK")
    On Error Resume Next
    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