'****************************************************方法一(普通模拟)****************************************************
'代码出处:http://www.codefans.net/articles/51.shtml
Public Enum DataEnum
    ResponseText = 1
    ResponseBody = 2
End Enum

Public Function GetData(ByVal Url As String, ByVal DataStic As DataEnum) As Variant
    
    On Error GoTo ERR:
    Dim XMLHTTP As Object
    Dim DataS As String
    Dim DataB() As Byte
    
    Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
    
    XMLHTTP.Open "get", Url, True
    XMLHTTP.Send
    
    While XMLHTTP.ReadyState <> 4
        DoEvents
    Wend
    '--------------------------------------函数返回
    Select Case DataStic
    Case ResponseText
        '--------------------------------直接返回字符串
        DataS = XMLHTTP.ResponseText
        GetData = DataS
    Case ResponseBody
        '--------------------------------直接返回二进制
        DataB = XMLHTTP.ResponseBody
        GetData = DataB
    Case ResponseBody + ResponseText
        '------------------------------二进制转字符串[直接返回字串出现乱码时尝试]
        DataS = BytesToStr(XMLHTTP.ResponseBody)
        GetData = DataS
    Case Else
        '--------------------------------无效的返回
        GetData = ""
    End Select
    '--------------------------------------释放空间
    Set XMLHTTP = Nothing
    Exit Function
ERR:
    GetData = ""
End Function

Public Function PostData(ByVal StrUrl As String, ByVal StrData As String, ByVal DataStic As DataEnum) As Variant
    On Error GoTo ERR:
    
    Dim XMLHTTP As Object
    Dim DataS As String
    Dim DataB() As Byte
    
    Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
    
    XMLHTTP.Open "POST", StrUrl, True
    XMLHTTP.SetRequestHeader "Content-Length", Len(PostData)
    XMLHTTP.SetRequestHeader "CONTENT-TYPE", "application/x-www-form-urlencoded"
    XMLHTTP.Send (StrData)
    
    Do Until XMLHTTP.ReadyState = 4
        DoEvents
    Loop
    '-----------------------------函数返回
    Select Case DataStic
    Case ResponseText
        '--------------------------------直接返回字符串
        DataS = XMLHTTP.ResponseText
        PostData = DataS
    Case ResponseBody
        '--------------------------------直接返回二进制
        DataB = XMLHTTP.ResponseBody
        PostData = DataB
    Case ResponseBody + ResponseText
        '---------------------------二进制转字符串[直接返回字串出现乱码时尝试]
        DataS = BytesToStr(XMLHTTP.ResponseBody)
        PostData = DataS
    Case Else
        '--------------------------------无效的返回
        PostData = ""
    End Select
    '------------------------------------释放空间
    Set XMLHTTP = Nothing
    Exit Function
ERR:
    PostData = ""
End Function

Function BytesToStr(ByVal vIn) As String
    strReturn = ""
    For i = 1 To LenB(vIn)
        ThisCharCode = AscB(MidB(vIn, i, 1))
        If ThisCharCode < &H80 Then
            strReturn = strReturn & Chr(ThisCharCode)
        Else
            NextCharCode = AscB(MidB(vIn, i + 1, 1))
            strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode))
            i = i + 1
        End If
    Next
    BytesToStr = strReturn
End Function
'----------------------------------------------以上代码放到标准模块中----------------------------------------------

Private Sub Command1_Click() '调用方法
    Text1.Text = GetData("http://www.baidu.com", ResponseText)              '模拟Get
    Text2.Text = PostData("http://www.baidu.com", 预发送数据, ResponseText) '模拟Post
End Sub


'****************************************************方法二(根据编码方式模拟)****************************************************
Public Function GetData(ByVal Url As String, ByVal CodeBase As String) As Variant
    Dim XMLHTTP As Object
    Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
    XMLHTTP.Open "Get", Url, True
    XMLHTTP.Send
    '--------------------------------------发送数据
    While XMLHTTP.ReadyState <> 4
        DoEvents
    Wend
    '--------------------------------------函数返回
    GetData = XMLHTTP.ResponseBody
    If CStr(GetData) <> "" Then GetData = BytesToBstr(GetData, CodeBase)
    Set XMLHTTP = Nothing
End Function

Public Function PostData(ByVal StrUrl As String, ByVal StrData As String, ByVal CodeBase As String) As Variant
    Dim XMLHTTP As Object
    Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
    XMLHTTP.Open "POST", StrUrl, True
    XMLHTTP.SetRequestHeader "Content-Length", Len(StrData)
    XMLHTTP.SetRequestHeader "CONTENT-TYPE", "application/x-www-form-urlencoded"
    XMLHTTP.Send (StrData)
    '--------------------------------------发送数据
    Do Until XMLHTTP.ReadyState = 4
        DoEvents
    Loop
    '--------------------------------------函数返回
    PostData = XMLHTTP.ResponseBody
    If CStr(PostData) <> "" Then PostData = BytesToBstr(PostData, CodeBase)
    Set XMLHTTP = Nothing
End Function

Public 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 Command1_Click() '调用方法
    Text1.Text = PostData("http://www.0756idc.com/user/userlogin.asp", "username=abc&password=123", "GBK")    '按GBK编码模拟Post
    'Text1.Text = PostData("http://www.0756idc.com/user/userlogin.asp", "username=abc&password=123", "GB2312") '按GB2312编码模拟Post
    'Text1.Text = PostData("http://www.0756idc.com/user/userlogin.asp", "username=abc&password=123", "UTF-8")  '按UTF-8编码模拟Post
    'Text1.Text = GetData("http://www.0756idc.com/user/", "GBK")    '按GBK编码模拟Get
    'Text1.Text = GetData("http://www.0756idc.com/user/", "GB2312") '按GB2312编码模拟Get
    'Text1.Text = GetData("http://www.0756idc.com/user/", "UTF-8")  '按UTF-8编码模拟Get
End Sub