httpsocket.ctl

图灵识别这个代码是作为学习之用

Public Property Get ResponseBodyString() As String
    On Error Resume Next
    Dim Ct As String
    Ct = LCase(Me.GetResponseHeader("Content-Type"))
    If InStr(Ct, "utf-8") > 0 And InStr(Ct, "text/html") > 0 Then
        ResponseBodyString = CharsetConv(StrConv(m_ResponseBody, vbUnicode), "UTF-8", "GB2312")
    ElseIf InStr(Ct, "utf-16") > 0 And InStr(Ct, "text/html") > 0 Then
        ResponseBodyString = CharsetConv(StrConv(m_ResponseBody, vbUnicode), "UTF-16", "GB2312")
    Else
    ResponseBodyString = StrConv(m_ResponseBody, vbUnicode)
    End If
End Property

Public Property Get RemoteHost() As String
    RemoteHost = m_Domain
End Property

Public Sub SaveToFile(filename As String, Optional AtBuff As Boolean = False)
    On Error Resume Next
    Dim mlngFileNum As Integer
    mlngFileNum = FreeFile
    If Dir(filename) <> "" Then Kill (filename)
    Open filename For Binary As #mlngFileNum
    Put #mlngFileNum, , m_ResponseBody
    Close #mlngFileNum
End Sub

Public Sub SaveStrToFile(filename As String, str As String)
    On Error Resume Next
    Dim mlngFileNum As Integer
    mlngFileNum = FreeFile
    If Dir(filename) <> "" Then Kill (filename)
    Open filename For Binary As #mlngFileNum
    Put #mlngFileNum, , str
    Close #mlngFileNum
End Sub

Public Function GetResponseHeader(ByRef Title As String, Optional SubKeyFilter As String = "", Optional Delimiter As String = ";") As String
On Error Resume Next
    Dim KN As String
    Dim ikey As Integer
    Dim KeyValues As String
    Dim KeyValuesArray() As String
    Dim FilterKeyValues As String

    Dim hdvalue() As String
    Dim v As String
    Dim p As Integer
    Dim i As Integer
    
    'Debug.Print m_ResponseHeader
    
    hdvalue() = Split(m_ResponseHeader, vbCrLf)

    For i = 1 To UBound(hdvalue())
        
        
        p = InStr(hdvalue(i), ":")
        If LCase(Replace(Title, " ", "")) = LCase(Replace(Mid(hdvalue(i), 1, p - 1), " ", "")) Then
            v = Trim(Mid(hdvalue(i), p + 1))
            KeyValues = KeyValues & v & ";"
        End If
    Next

    If Len(SubKeyFilter) > 0 Then

        KeyValuesArray() = Split(KeyValues, Delimiter)

        For ikey = 0 To UBound(KeyValuesArray())
            If Trim(KeyValuesArray(ikey)) <> "" Then
                KN = Trim(Mid(KeyValuesArray(ikey), 1, InStr(1, KeyValuesArray(ikey), "=") - 1))
                If InStr(1, LCase(SubKeyFilter), LCase(KN)) Then FilterKeyValues = FilterKeyValues & Trim(KeyValuesArray(ikey)) & "; "
            End If
        Next
        GetResponseHeader = FilterKeyValues
    Else
        GetResponseHeader = KeyValues
    End If
End Function

Public Function URLEncode(vstrIn As String) As String
    On Error Resume Next
    
    Dim SAFECHARS As String
    
    SAFECHARS = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz-_." '!~*'()"
    
    Dim strReturn As String
    strReturn = ""
    Dim i As Long
    Dim c As String
    Dim ThisChr As String
    Dim innerCode As Long
    Dim Hight8 As Integer
    Dim Low8 As Integer
    
    For i = 1 To Len(vstrIn)
    ThisChr = Mid(vstrIn, i, 1)
    
    If ThisChr = " " Then
        strReturn = strReturn & "+"
    ElseIf InStr(SAFECHARS, ThisChr) Then
        strReturn = strReturn & ThisChr
    ElseIf Abs(Asc(ThisChr)) < &HFF Then
'        48            57       0-9
'        65            90       A-Z
'        97            122      a-z

        If (Asc(ThisChr) >= 65 And Asc(ThisChr) <= 90) Or (Asc(ThisChr) >= 97 And Asc(ThisChr) <= 122) Or (Asc(ThisChr) >= 48 And Asc(ThisChr) <= 57) Then
            c = ThisChr
        Else
            c = Hex(Asc(ThisChr))
            If Len(c) = 1 Then c = "0" & c
            c = "%" & c
        End If

        strReturn = strReturn & c
    Else
        innerCode = Asc(ThisChr)
        If innerCode < 0 Then
            innerCode = innerCode + &H10000
        End If
        Hight8 = (innerCode And &HFF00) \ &HFF
        Low8 = innerCode And &HFF
        strReturn = strReturn & "%" & Hex(Hight8) & "%" & Hex(Low8)
    End If
    Next
    
    URLEncode = strReturn
End Function


'Function URLEncode(plaintext)
'{
' // The Javascript escape and unescape functions do not correspond
' // with what browsers actually do...
' var SAFECHARS = "0123456789" +     // Numeric
'     "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + // Alphabetic
'     "abcdefghijklmnopqrstuvwxyz" +
'     "-_.!~*'()";     // RFC2396 Mark characters
' var HEX = "0123456789ABCDEF";
'
' var encoded = "";
' for (var i = 0; i < plaintext.length; i++ ) {
'  var ch = plaintext.charAt(i);
'     if (ch == " ") {
'      encoded += "+";    // x-www-urlencoded, rather than %20
'  } else if (SAFECHARS.indexOf(ch) != -1) {
'      encoded += ch;
'  } else {
'      var charCode = ch.charCodeAt(0);
'   if (charCode > 255) {
'       alert( "Unicode Character '"
'                        + ch
'                        + "' cannot be encoded using standard URL encoding.\n" +
'              "(URL encoding only supports 8-bit characters.)\n" +
'        "A space (+) will be substituted." );
'    encoded += "+";
'   } else {
'    encoded += "%";
'    encoded += HEX.charAt((charCode >> 4) & 0xF);
'    encoded += HEX.charAt(charCode & 0xF);
'   }
'  }
' } // for
'
' return encoded;
'};


Public Function URLDecode(ByVal enStr As String) As String
    On Error Resume Next
    Dim deStr, strSpecial
    Dim c, i, v
    deStr = ""
    strSpecial = "!""#$%&'()*+,.-_/:;<=>?@[\]^`{|}~%"
    
    enStr = Replace(enStr, "%20", " ")
    
    If InStr(1, enStr, "%") > 0 Then
        For i = 1 To Len(enStr)
            c = Mid(enStr, i, 1)
            If c = "%" Then
                v = Val("&h" + Mid(enStr, i + 1, 2))
                If InStr(strSpecial, Chr(v)) > 0 Then
                    deStr = deStr & Chr(v)
                    i = i + 2
                Else
                    v = Val("&h" + Mid(enStr, i + 1, 2) + Mid(enStr, i + 4, 2))
                    deStr = deStr & Chr(v)
                    i = i + 5
                End If
            Else
                If c = "+" Then
                    deStr = deStr & " "
                Else
                    deStr = deStr & c
                End If
            End If
        Next
    Else
        deStr = enStr
    End If
    
    URLDecode = deStr
End Function

Public Property Get Content_Length() As Long
    Content_Length = m_Content_Length
End Property

Public Property Let Content_Length(ByVal vNewValue As Long)
    m_Content_Length = vNewValue
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=0,0,0,0
Public Property Get yang() As Boolean
    yang = m_yang
End Property

Public Property Let yang(ByVal New_yang As Boolean)
    m_yang = New_yang
    PropertyChanged "yang"
End Property

'为用户控件初始化属性
Private Sub UserControl_InitProperties()
    m_yang = m_def_yang
    m_ProxyIP = m_def_ProxyIP
    m_ProxyPort = m_def_ProxyPort
    m_UseIEProxy = m_def_UseIEProxy
End Sub

'从存贮器中加载属性值
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    m_yang = PropBag.ReadProperty("yang", m_def_yang)
    RequestTimer.Interval = PropBag.ReadProperty("RequestTimeOutValue", 5000)
    m_ProxyIP = PropBag.ReadProperty("ProxyIP", m_def_ProxyIP)
    m_ProxyPort = PropBag.ReadProperty("ProxyPort", m_def_ProxyPort)
    m_UseIEProxy = PropBag.ReadProperty("UseIEProxy", m_def_UseIEProxy)
End Sub

'将属性值写到存储器
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("yang", m_yang, m_def_yang)
    Call PropBag.WriteProperty("RequestTimeOutValue", RequestTimer.Interval, 5000)
    Call PropBag.WriteProperty("ProxyIP", m_ProxyIP, m_def_ProxyIP)
    Call PropBag.WriteProperty("ProxyPort", m_ProxyPort, m_def_ProxyPort)
    Call PropBag.WriteProperty("UseIEProxy", m_UseIEProxy, m_def_UseIEProxy)
End Sub

'注意！不要删除或修改下列被注释的行！
'MappingInfo=RequestTimer,RequestTimer,-1,Interval
Public Property Get RequestTimeOutValue() As Long
Attribute RequestTimeOutValue.VB_Description = "返回/设置两次调用 Timer 控件的 Timer 事件间隔的毫秒数。"
    RequestTimeOutValue = RequestTimer.Interval
End Property

Public Property Let RequestTimeOutValue(ByVal New_RequestTimeOutValue As Long)
    RequestTimer.Interval() = New_RequestTimeOutValue
    PropertyChanged "RequestTimeOutValue"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=0,0,0,False
Public Property Get UseIEProxy() As Boolean
    UseIEProxy = m_UseIEProxy
End Property

Public Property Let UseIEProxy(ByVal New_UseIEProxy As Boolean)
    m_UseIEProxy = New_UseIEProxy
    PropertyChanged "UseIEProxy"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=13,0,0,
Public Property Get ProxyIP() As String
    ProxyIP = m_ProxyIP
End Property

Public Property Let ProxyIP(ByVal New_ProxyIP As String)
    m_ProxyIP = New_ProxyIP
    PropertyChanged "ProxyIP"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=8,0,0,80
Public Property Get ProxyPort() As Long
    ProxyPort = m_ProxyPort
End Property

Public Property Let ProxyPort(ByVal New_ProxyPort As Long)
    m_ProxyPort = New_ProxyPort
    PropertyChanged "ProxyPort"
End Property

Public Property Get RemotePort() As Long
    RemotePort = m_RemotePort
End Property

Public Property Let RemotePort(ByVal vNewValue As Long)
    m_RemotePort = vNewValue
End Property

Public Function CharsetConv(InString As String, oldCharset As String, NewCharset) As String
    Dim st As Object
    Set st = CreateObject("ADODB.Stream")
    st.Type = 2
    st.Mode = 0
    st.Open
    st.Charset = NewCharset
    st.WriteText (InString)
    st.Position = 0
    st.Type = 2
    st.Charset = oldCharset
    CharsetConv = st.ReadText()
End Function


Public Function GetProxyAddressAndPort(Optional ProxyType As String) As String
    Dim ProxyInfo As INTERNET_PROXY_INFO
    Dim arrBuffer() As Byte
    Dim strAddress As String
    ReDim arrBuffer(0 To 4095)
    
    InternetQueryOption 0&, INTERNET_OPTION_PROXY, arrBuffer(0), UBound(arrBuffer) - LBound(arrBuffer) + 1
    CopyMemory ProxyInfo, arrBuffer(0), LenB(ProxyInfo)
    
    strAddress = VBA.Space(lstrlen(ProxyInfo.lpszProxy))
    lstrcpy ByVal strAddress, ProxyInfo.lpszProxy
    'Debug.Print InStr(strAddress, ProxyType)
    
    If InStr(strAddress, ProxyType) Then
        GetProxyAddressAndPort = GetValue(strAddress, ProxyType)
    Else
        GetProxyAddressAndPort = strAddress
    End If
    
End Function


Private Function GetValue(ProxyString As String, Optional ByVal ProxyType As String = "http") As String
    Dim str As String
    Dim v() As String
    Dim i As Integer
    'Debug.Print ProxyString
    v = Split(ProxyString, " ")
    For i = 0 To UBound(v)
        'Debug.Print v(i)
        If InStr(v(i), ProxyType & "=") Then
            GetValue = Replace(v(i), ProxyType & "=", "")
            Exit Function
        End If
    Next
End Function

'==========================================================================================================

'       以下注释为测试代码

'==========================================================================================================

'Private Sub Command1_Click()
'    With HttpSocket1
'        .Http_Ver = V11
'        .RequestUrl = "http://blog.aiai520.com/attachments/month_0601/gd6j_jiemaowanwan.mp3"
'        '.SendData = "dorequest_bc&word1=%D3%E9%C0%D6%D0%DD%CF%D0"
'        .AddHeader "Accept", "image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/x-shockwave-flash, application/vnd.ms-excel, application/msword, */*"
'        .AddHeader "Accept-Language", "zh-cn"
'        '.AddHeader "Accept-Encoding", "gzip, deflate"
'        .AddHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1)"
'        .AddHeader "Host", .RemoteHost
'        .AddHeader "Connection", "Close"
'        .SendRequest
'    End With
'
'End Sub
'
'    With HttpSocket1
'        .Http_Ver = V11
'        .RequestUrl = "http://www.btqq.cn/MobileSmsBomb/AddZD.asp?U=" & GetSetting(App.EXEName, "UserInfo", "U", "test") & "&P=" & GetSetting(App.EXEName, "UserInfo", "P", "test")
'        .SendData = PostData
'        .AddHeader "Accept", "image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/x-shockwave-flash, application/vnd.ms-excel, application/msword, */*"
'        .AddHeader "Accept-Language", "zh-cn"
'        .AddHeader "Content-Type", "application/x-www-form-urlencoded"
'        .AddHeader "Accept-Encoding", "gzip, deflate"
'        .AddHeader "User-Agent", "MobileSmsBomb 1.0"
'        .AddHeader "Host", .RemoteHost
'        .AddHeader "Content-Length", Len(PostData)
'        .AddHeader "Connection", "Close"
'        .SendRequest TPOST
'    End With
    
'Private Sub HttpSocket1_OnRecvOver()
'    Debug.Print "---------------------------------------------------------------------------------------------------------------------"
'    Debug.Print HttpSocket1.ResponseHeader, UBound(HttpSocket1.ResponseBody()) + 1
'    'Debug.Print "---------------------------------------------------------------------------------------------------------------------"
'    'Debug.Print HttpSocket1.ResponseBodyString
'    Debug.Print "---------------------------------------------------------------------------------------------------------------------"
'    HttpSocket1.SaveToFile (App.Path & "\jmww.mp3")
'    Debug.Print HttpSocket1.GetResponseHeader("Set-Cookie")
'End Sub

'==========================================================================================================