VBFunctionBas/HttpHelper.bas

Attribute VB_Name = "HttpHelper"
'#######################################用户控件说明#########################################

'名称:XmlHttp控件

'功能:实现XmlHttp的网络处理功能。

'最后更新日期:2014年6月4日

'创建人:蒋天蓓

'单位:上海市定海水电工程安装有限公司

'#######################################用户控件说明#########################################
'****************************************************
'GET网页：GetData (网址 As String, 数据类型 As DataEnum )
'****************************************************
'POST网页：PostData (网址 As String, 数据类型 As DataEnum )
'****************************************************

'XmlHttp.Status 常见值
'Web服务器响应浏览器或其他客户程序的请求时，其应答一般由以下几个部分组成：一个状态行，几个应答头，一个空行，内容文档。下面是一个最简单的应答：
'
'　　状态行包含HTTP版本、状态代码、与状态代码对应的简短说明信息。在大多数情况下，除了Content-Type之外的所有应答头都是可选的。但Content-Type是必需的，它描述的是后面文档的MIME类型。虽然大多数应答都包含一个文档，但也有一些不包含，例如对HEAD请求的应答永远不会附带文档。有许多状态代码实际上用来标识一次失败的请求，这些应答也不包含文档（或只包含一个简短的错误信息说明）。
'
'　　当用户试图通过 HTTP 访问一台正在运行 Internet 信息服务 (IIS) 的服务器上的内容时，IIS 返回一个表示该请求的状态的数字代码。状态代码可以指明具体请求是否已成功，还可以揭示请求失败的确切原因。
'
'1 xx -信息提示
'
'这些状态代码表示临时的响应。客户端在收到常规响应之前，应准备接收一个或多个 1xx 响应。
'　· 100 - Continue 初始的请求已经接受，客户应当继续发送请求的其余部分。（HTTP 1.1新）
'　· 101 - Switching Protocols 服务器将遵从客户的请求转换到另外一种协议（HTTP 1.1新）
'
'2 xx -成功
'
'这类状态代码表明服务器成功地接受了客户端请求?
'　· 200 - OK 一切正常，对GET和POST请求的应答文档跟在后面。
'　· 201 - Created 服务器已经创建了文档，Location头给出了它的URL。
'　· 202 - Accepted 已经接受请求，但处理尚未完成。
'　· 203 - Non-Authoritative Information 文档已经正常地返回，但一些应答头可能不正确，因为使用的是文档的拷贝，非权威性信息（HTTP 1.1新）。
'　· 204 - No Content 没有新文档，浏览器应该继续显示原来的文档。如果用户定期地刷新页面，而Servlet可以确定用户文档足够新，这个状态代码是很有用的。
'　· 205 - Reset Content 没有新的内容，但浏览器应该重置它所显示的内容。用来强制浏览器清除表单输入内容（HTTP 1.1新）。
'　· 206 - Partial Content 客户发送了一个带有Range头的GET请求，服务器完成了它（HTTP 1.1新）。
'
'3 xx -重定向
'
'客户端浏览器必须采取更多操作来实现请求。例如，浏览器可能不得不请求服务器上的不同的页面，或通过代理服务器重复该请求。
'　· 300 - Multiple Choices 客户请求的文档可以在多个位置找到，这些位置已经在返回的文档内列出。如果服务器要提出优先选择，则应该在Location应答头指明。
'　· 301 - Moved Permanently 客户请求的文档在其他地方，新的URL在Location头中给出，浏览器应该自动地访问新的URL。
'　· 302 - Found 类似于301，但新的URL应该被视为临时性的替代，而不是永久性的。注意，在HTTP1.0中对应的状态信息是“Moved Temporatily”。出现该状态代码时，浏览器能够自动访问新的URL，因此它是一个很有用的状态代码。注意这个状态代码有时候可以和301替换使用。例如，如果浏览器错误地请求 http://host/~user （缺少了后面的斜杠），有的服务器返回301，有的则返回302。严格地说，我们只能假定只有当原来的请求是GET时浏览器才会自动重定向。请参见307。
'　· 303 - See Other 类似于301/302，不同之处在于，如果原来的请求是POST，Location头指定的重定向目标文档应该通过GET提取（HTTP 1.1新）。
'　· 304 - Not Modified 客户端有缓冲的文档并发出了一个条件性的请求（一般是提供If-Modified-Since头表示客户只想比指定日期更新的文档）。服务器告诉客户，原来缓冲的文档还可以继续使用。
'　· 305 - Use Proxy 客户请求的文档应该通过Location头所指明的代理服务器提取（HTTP 1.1新）。
'　· 307 - Temporary Redirect 和302（Found）相同。许多浏览器会错误地响应302应答进行重定向，即使原来的请求是POST，即使它实际上只能在POST请求的应答是303时才能重定向。由于这个原因，HTTP 1.1新增了307，以便更加清除地区分几个状态代码：当出现303应答时，浏览器可以跟随重定向的GET和POST请求；如果是307应答，则浏览器只能跟随对GET请求的重定向。（HTTP 1.1新）
'
'4 xx -客户端错误
'
'发生错误，客户端似乎有问题。例如，客户端请求不存在的页面，客户端未提供有效的身份验证信息。
'
'　· 400 - Bad Request 请求出现语法错误。
'　· 401 - Unauthorized 访问被拒绝，客户试图未经授权访问受密码保护的页面。应答中会包含一个WWW-Authenticate头，浏览器据此显示用户名字/密码对话框，然后在填写合适的Authorization头后再次发出请求。IIS 定义了许多不同的 401 错误，它们指明更为具体的错误原因。这些具体的错误代码在浏览器中显示，但不在 IIS 日志中显示：
'  · 401.1 - 登录失败?
'  · 401.2 - 服务器配置导致登录失败?
'　· 401.3 - 由于 ACL 对资源的限制而未获得授权。
'  · 401.4 - 筛选器授权失败?
'　· 401.5 - ISAPI/CGI 应用程序授权失败。
'　· 401.7 – 访问被 Web 服务器上的 URL 授权策略拒绝。这个错误代码为 IIS 6.0 所专用。
'　· 403 - Forbidden 资源不可用。服务器理解客户的请求，但拒绝处理它。通常由于服务器上文件或目录的权限设置导致。禁止访问：IIS 定义了许多不同的 403 错误，它们指明更为具体的错误原因：
'  · 403.1 - 执行访问被禁止?
'  · 403.2 - 读访问被禁止?
'  · 403.3 - 写访问被禁止?
'　· 403.4 - 要求 SSL。
'　· 403.5 - 要求 SSL 128。
'　· 403.6 - IP 地址被拒绝。
'  · 403.7 - 要求客户端证书?
'  · 403.8 - 站点访问被拒绝?
'  · 403.9 - 用户数过多?
'  · 403.1 - 配置无效?
'  · 403.11 - 密码更改?
'  · 403.12 - 拒绝访问映射表?
'  · 403.13 - 客户端证书被吊销?
'  · 403.14 - 拒绝目录列表?
'  · 403.15 - 超出客户端访问许可?
'  · 403.16 - 客户端证书不受信任或无效?
'  · 403.17 - 客户端证书已过期或尚未生效?
'　· 403.18 - 在当前的应用程序池中不能执行所请求的 URL。这个错误代码为 IIS 6.0 所专用。
'　· 403.19 - 不能为这个应用程序池中的客户端执行 CGI。这个错误代码为 IIS 6.0 所专用。
'　· 403.20 - Passport 登录失败。这个错误代码为 IIS 6.0 所专用。
'　· 404 - Not Found 无法找到指定位置的资源。这也是一个常用的应答。
'　· 404.0 -（无） – 没有找到文件或目录。
'　· 404.1 - 无法在所请求的端口上访问 Web 站点。
'　· 404.2 - Web 服务扩展锁定策略阻止本请求。
'　· 404.3 - MIME 映射策略阻止本请求。
'
'　· 405 - Method Not Allowed 请求方法（GET、POST、HEAD、DELETE、PUT、TRACE等）对指定的资源不适用，用来访问本页面的 HTTP 谓词不被允许（方法不被允许）（HTTP 1.1新）
'　· 406 - Not Acceptable 指定的资源已经找到，但它的MIME类型和客户在Accpet头中所指定的不兼容，客户端浏览器不接受所请求页面的 MIME 类型（HTTP 1.1新）。
'　· 407 - Proxy Authentication Required 要求进行代理身份验证，类似于401，表示客户必须先经过代理服务器的授权。（HTTP 1.1新）
'　· 408 - Request Timeout 在服务器许可的等待时间内，客户一直没有发出任何请求。客户可以在以后重复同一请求。（HTTP 1.1新）
'　· 409 - Conflict 通常和PUT请求有关。由于请求和资源的当前状态相冲突，因此请求不能成功。（HTTP 1.1新）
'　· 410 - Gone 所请求的文档已经不再可用，而且服务器不知道应该重定向到哪一个地址。它和404的不同在于，返回407表示文档永久地离开了指定的位置，而404表示由于未知的原因文档不可用。（HTTP 1.1新）
'　· 411 - Length Required 服务器不能处理请求，除非客户发送一个Content-Length头。（HTTP 1.1新）
'　· 412 - Precondition Failed 请求头中指定的一些前提条件失败（HTTP 1.1新）。
'　· 413 – Request Entity Too Large 目标文档的大小超过服务器当前愿意处理的大小。如果服务器认为自己能够稍后再处理该请求，则应该提供一个Retry-After头（HTTP 1.1新）。
'　· 414 - Request URI Too Long URI太长（HTTP 1.1新）。
'　· 415 – 不支持的媒体类型。
'　· 416 – Requested Range Not Satisfiable 服务器不能满足客户在请求中指定的Range头。（HTTP 1.1新）
'　· 417 – 执行失败。
'　· 423 – 锁定的错误。
'
'5 xx -服务器错误
'
'服务器由于遇到错误而不能完成该请求?
'
'　· 500 - Internal Server Error 服务器遇到了意料不到的情况，不能完成客户的请求。
'　· 500.12 - 应用程序正忙于在 Web 服务器上重新启动。
'　· 500.13 - Web 服务器太忙。
'　· 500.15 - 不允许直接请求 Global.asa。
'　· 500.16 – UNC 授权凭据不正确。这个错误代码为 IIS 6.0 所专用。
'　· 500.18 – URL 授权存储不能打开。这个错误代码为 IIS 6.0 所专用。
'　· 500.100 - 内部 ASP 错误。
'　· 501 - Not Implemented 服务器不支持实现请求所需要的功能，页眉值指定了未实现的配置。例如，客户发出了一个服务器不支持的PUT请求。
'　· 502 - Bad Gateway 服务器作为网关或者代理时，为了完成请求访问下一个服务器，但该服务器返回了非法的应答。 亦说Web 服务器用作网关或代理服务器时收到了无效响应。
'　· 502.1 - CGI 应用程序超时。
'　· 502.2 - CGI 应用程序出错。
'　· 503 - Service Unavailable 服务不可用，服务器由于维护或者负载过重未能应答。例如，Servlet可能在数据库连接池已满的情况下返回503。服务器返回503时可以提供一个Retry-After头。这个错误代码为 IIS 6.0 所专用。
'　· 504 - Gateway Timeout 网关超时，由作为代理或网关的服务器使用，表示不能及时地从远程服务器获得应答。（HTTP 1.1新） 。
'· 505 - HTTP Version Not Supported 服务器不支持请求中所指明的HTTP版本。（HTTP 1.1新）。
Option Explicit

Public Enum DataEnum
    ResponseText = 1
    ResponseBody = 2
    ResponseBodyToText = 3
End Enum

Private Type TGUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

'// 用来加载Internet上的图片
Private Declare Function OleLoadPicturePath Lib "oleaut32.dll" (ByVal szURLorPath As Long, ByVal punkCaller As Long, ByVal dwReserved As Long, ByVal clrReserved As OLE_COLOR, ByRef riid As TGUID, ByRef ppvRet As IPicture) As Long

Public Function GetData(ByVal url As String, Optional ByVal DataStic As DataEnum) As Variant

    'On Error GoTo ERR:
    Dim XmlHttp As Object
    Dim DataS As String
    Dim DataB() As Byte
    Dim DataB2S As String

    Set XmlHttp = CreateObject("Msxml2.XMLHTTP")
    If Not IsObject(XmlHttp) Then
        Set XmlHttp = CreateObject("Microsoft.XMLHTTP")
        If Not IsObject(XmlHttp) Then Exit Function
    End If

    If url = "" Then Exit Function

    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 ResponseBodyToText
        '----------------------------------二进制转字符串[直接返回字串出现乱码时尝试]
        DataB2S = BytesToStr(XmlHttp.ResponseBody)
        GetData = DataB2S
    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, _
                         Optional ByVal DataType As String = "application/x-www-form-urlencoded", Optional ByVal UrlCode As Boolean) As Variant
    On Error GoTo ERR:

    Dim XmlHttp As Object
    Dim DataS As String
    Dim DataB() As Byte
    Dim DataB2S As String
    Set XmlHttp = CreateObject("Msxml2.XMLHTTP")
    If Not IsObject(XmlHttp) Then
        Set XmlHttp = CreateObject("Microsoft.XMLHTTP")
        If Not IsObject(XmlHttp) Then Exit Function
    End If

    XmlHttp.Open "POST", strURL, True
    XmlHttp.SetRequestHeader "Content-Length", Len(PostData)
    XmlHttp.SetRequestHeader "CONTENT-TYPE", DataType
    If UrlCode Then StrData = URLEncode(StrData)
    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 ResponseBodyToText
        '--------------------------------二进制转字符串[直接返回字串出现乱码时尝试]
        DataB2S = BytesToStr(XmlHttp.ResponseBody)
        PostData = DataB2S
    Case Else
        '--------------------------------无效的返回
        PostData = ""
    End Select
    '------------------------------------释放空间
    Set XmlHttp = Nothing
    Exit Function
ERR:
    PostData = ""
End Function

'================获得外网IP======================
Public Function GetWanIp()
    On Error Resume Next
    Dim Temp
    Temp = GetData("http://members.3322.org/dyndns/getip", ResponseBodyToText)
    Debug.Print Temp
    If Temp = "" Then
        GetWanIp = ""
    Else
        GetWanIp = Temp
    End If
End Function

'// 从Internet上加载图片
Public Function LoadPicture(ByVal strFileName As String) As Picture
    Dim IID As TGUID
    With IID
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With

    On Error GoTo LocalErr

    OleLoadPicturePath StrPtr(strFileName), 0&, 0&, 0&, IID, LoadPicture
    Exit Function
LocalErr:
    Set LoadPicture = VB.LoadPicture(strFileName)
    ERR.Clear
End Function

Private Function BytesToStr(Bytes)
    Dim Unicode As String
    If IsUTF8(Bytes) Then    '如果不是UTF-8编码则按照GB2312来处理
        Unicode = "UTF-8"
    Else
        Unicode = "GB2312"
    End If

    Dim objstream As Object
    Set objstream = CreateObject("ADODB.Stream")
    With objstream
        .Type = 1
        .Mode = 3
        .Open
        .Write Bytes
        .Position = 0
        .Type = 2
        .Charset = Unicode
        BytesToStr = .ReadText
        .Close
    End With
End Function

'判断网页编码函数
Private Function IsUTF8(Bytes) As Boolean
    On Error Resume Next
    Dim i As Long, AscN As Long, Length As Long
    Length = UBound(Bytes) + 1

    If Length < 3 Then
        IsUTF8 = False
        Exit Function
    ElseIf Bytes(0) = &HEF And Bytes(1) = &HBB And Bytes(2) = &HBF Then
        IsUTF8 = True
        Exit Function
    End If

    Do While i <= Length - 1
        If Bytes(i) < 128 Then
            i = i + 1
            AscN = AscN + 1
        ElseIf (Bytes(i) And &HE0) = &HC0 And (Bytes(i + 1) And &HC0) = &H80 Then
            i = i + 2

        ElseIf i + 2 < Length Then
            If (Bytes(i) And &HF0) = &HE0 And (Bytes(i + 1) And &HC0) = &H80 And (Bytes(i + 2) And &HC0) = &H80 Then
                i = i + 3
            Else
                IsUTF8 = False
                Exit Function
            End If
        Else
            IsUTF8 = False
            Exit Function
        End If
    Loop

    If AscN = Length Then
        IsUTF8 = False
    Else
        IsUTF8 = True
    End If

End Function

'编码函数
Public Function URLEncode(ByRef strURL As String) As String
    Dim i As Long
    Dim tempStr As String
    For i = 1 To Len(strURL)
        If Asc(Mid(strURL, i, 1)) < 0 Then
            tempStr = "%" & Right(CStr(Hex(Asc(Mid(strURL, i, 1)))), 2)
            tempStr = "%" & Left(CStr(Hex(Asc(Mid(strURL, i, 1)))), Len(CStr(Hex(Asc(Mid(strURL, i, 1))))) - 2) & tempStr
            URLEncode = URLEncode & tempStr
        ElseIf (Asc(Mid(strURL, i, 1)) >= 65 And Asc(Mid(strURL, i, 1)) <= 90) Or (Asc(Mid(strURL, i, 1)) >= 97 And Asc(Mid(strURL, i, 1)) <= 122) Then
            URLEncode = URLEncode & Mid(strURL, i, 1)
        Else
            URLEncode = URLEncode & "%" & Hex(Asc(Mid(strURL, i, 1)))
        End If
    Next
End Function

'解码函数
Public Function URLDecode(ByRef strURL As String) As String
    Dim i As Long

    If InStr(strURL, "%") = 0 Then URLDecode = strURL: Exit Function

    For i = 1 To Len(strURL)
        If Mid(strURL, i, 1) = "%" Then
            If Val("&H" & Mid(strURL, i + 1, 2)) > 127 Then
                URLDecode = URLDecode & Chr(Val("&H" & Mid(strURL, i + 1, 2) & Mid(strURL, i + 4, 2)))
                i = i + 5
            Else
                URLDecode = URLDecode & Chr(Val("&H" & Mid(strURL, i + 1, 2)))
                i = i + 2
            End If
        Else
            URLDecode = URLDecode & Mid(strURL, i, 1)
        End If
    Next
End Function

'UTF-8 URL编码
Public Function UTF8_URLEncoding(ByVal szInput As String)
    Dim wch, uch, szRet
    Dim X
    Dim nAsc, nAsc2, nAsc3
    If szInput = "" Then
        UTF8_URLEncoding = szInput
        Exit Function
    End If
    For X = 1 To Len(szInput)
        wch = Mid(szInput, X, 1)
        nAsc = AscW(wch)
       
        If nAsc < 0 Then nAsc = nAsc + 65536
       
        If (nAsc And &HFF80) = 0 Then
            szRet = szRet & wch
        Else
            If (nAsc And &HF000) = 0 Then
                uch = "%" & Hex(((nAsc \ 2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80)
                szRet = szRet & uch
            Else
                uch = "%" & Hex((nAsc \ 2 ^ 12) Or &HE0) & "%" & _
                Hex((nAsc \ 2 ^ 6) And &H3F Or &H80) & "%" & _
                Hex(nAsc And &H3F Or &H80)
                szRet = szRet & uch
            End If
        End If
    Next
    UTF8_URLEncoding = szRet
End Function


'UTF-8 URL解码
Public Function UTF8_URLDecode(ByVal url As String)
    Dim B, ub   ''中文字的Unicode码(2字节)
    Dim UtfB    ''Utf-8单个字节
    Dim UtfB1, UtfB2, UtfB3 ''Utf-8码的三个字节
    Dim i, n, S
    n = 0
    ub = 0
    For i = 1 To Len(url)
        B = Mid(url, i, 1)
        Select Case B
            Case "+"
                S = S & " "
            Case "%"
                ub = Mid(url, i + 1, 2)
                UtfB = CInt("&H" & ub)
                If UtfB < 128 Then
                    i = i + 2
                    S = S & ChrW(UtfB)
                Else
                    UtfB1 = (UtfB And &HF) * &H1000   ''取第1个Utf-8字节的二进制后4位
                    UtfB2 = (CInt("&H" & Mid(url, i + 4, 2)) And &H3F) * &H40      ''取第2个Utf-8字节的二进制后6位
                    UtfB3 = CInt("&H" & Mid(url, i + 7, 2)) And &H3F      ''取第3个Utf-8字节的二进制后6位
                    S = S & ChrW(UtfB1 Or UtfB2 Or UtfB3)
                    i = i + 8
                End If
            Case Else    ''Ascii码
                S = S & B
        End Select
    Next
    UTF8_URLDecode = S
End Function