httpsocket.ctl

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

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.UserControl HttpSocket 
   ClientHeight    =   735
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1185
   ScaleHeight     =   735
   ScaleWidth      =   1185
   Begin VB.Timer RequestTimer 
      Enabled         =   0   'False
      Interval        =   30000
      Left            =   720
      Top             =   270
   End
   Begin MSWinsockLib.Winsock Winsock1 
      Left            =   210
      Top             =   120
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
End
Attribute VB_Name = "HttpSocket"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Type INTERNET_PROXY_INFO
    dwAccessType    As Long
    lpszProxy       As Long
    lpszProxyBypass As Long
End Type
Private Const INTERNET_OPTION_PROXY = 38
Private Declare Function InternetSetOption Lib "wininet.dll" Alias "InternetSetOptionA" (ByVal hInternet As Long, ByVal dwOption As Long, ByRef lpBuffer As Any, ByVal dwBufferLength As Long) As Long
Private Declare Function InternetQueryOption Lib "wininet.dll" Alias "InternetQueryOptionA" (ByVal hInternet As Long, ByVal dwOption As Long, ByRef lpBuffer As Any, ByRef dwBufferLength As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef pDest As Any, ByRef pSource As Any, ByVal Length As Long)
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long


Private Const m_def_PORT = 80
Private Const m_def_HTTPVER = 2


Private m_HDstring As String

Private m_RequestUrl As String
Private m_SendData As String

Private m_Domain As String
Private m_RemotePort As Long
Private m_Path As String

Private m_ResponseHeader As String
Private m_ResponseBody() As Byte

Private m_RequestType As RequestType
Private m_HTTPVer As E_Http_Ver

Public Enum RequestType
    TGET = 0
    TPOST = 1
End Enum

Public Enum E_Http_Ver
    V09 = 0
    V10 = 1
    V11 = 2
End Enum

Private m_Content_Length As Long
Private buff() As Byte
Private DataStart As Long
Private HeaderEnd As Boolean

Public Event OnRecvDataLen(recvlen As Long)
Public Event OnRecvOver()
Public Event OnReveHeaderOver()
Public Event OnReveStatusCode(CodeNumber As Integer)

Public Event RequestTimeOut()
Public Event Connect()
Public Event Error(ByVal number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
'缺省属性值:
Const m_def_UseIEProxy = False
Const m_def_ProxyIP = ""
Const m_def_ProxyPort = 80
Const m_def_yang = 0
'属性变量:
Dim m_UseIEProxy As Boolean
Dim m_ProxyIP As String
Dim m_ProxyPort As Long
Dim m_yang As Boolean


Public Sub AddHeader(HDstr As String, Optional hdvalue As String = "")
    If LCase(Trim(HDstr)) = "host" And Trim(m_Domain) <> "" And hdvalue = "" Then
        m_HDstring = Trim(m_HDstring) & HDstr & ": " & m_Domain & IIf(m_RemotePort <> 80, ":" & m_RemotePort, "") & vbCrLf
    Else
        m_HDstring = Trim(m_HDstring) & HDstr & ": " & Trim(hdvalue) & vbCrLf
    End If
End Sub

Public Sub SendRequest(Optional ByVal RT As RequestType = TGET)
    On Error Resume Next
    m_RequestType = RT

    If Winsock1.State <> sckClosed Then Winsock1.Close
    
    '--------------------------
    '复位一些变量
    Erase buff
    m_ResponseHeader = ""
    Erase m_ResponseBody
    DataStart = 0
    HeaderEnd = False
    m_Content_Length = 0
    RequestTimer.Enabled = True
    '--------------------------
    
    '读取IE代理
    
    If m_UseIEProxy = True Then
        Dim ProxyString As String
        Dim ProxyArray() As String
        ProxyString = Trim(GetProxyAddressAndPort("http"))
        If ProxyString <> "" And ProxyString <> m_ProxyIP & ":" & m_ProxyPort Then
            If InStr(ProxyString, ":") Then
                ProxyArray = Split(ProxyString, ":")
                m_ProxyIP = ProxyArray(0)
                m_ProxyPort = ProxyArray(1)
            Else
                m_ProxyIP = ProxyString
                m_ProxyPort = 80
            End If
        End If
    Else
        m_ProxyIP = ""
        m_ProxyPort = 0
    End If
    
    Debug.Print m_Domain, m_RemotePort
    
    If Trim(m_ProxyIP) <> "" Then
        Winsock1.Connect m_ProxyIP, m_ProxyPort
    Else
        Winsock1.Connect m_Domain, m_RemotePort
    End If
End Sub

Private Sub RequestTimer_Timer()
    If DataStart = 0 Then
        RequestTimer.Enabled = False
        Winsock1.Close
        RaiseEvent RequestTimeOut
    End If
End Sub

Private Sub UserControl_Initialize()
    m_RemotePort = m_def_PORT
    m_HTTPVer = m_def_HTTPVER
    Winsock1.Protocol = sckTCPProtocol
End Sub

Private Sub Winsock1_Close()
    On Error Resume Next
    m_ResponseBody = MidB(buff, DataStart)

    If m_yang Then
        Dim p As Long
        Dim sizelength As Long
        Dim flag As String

        p = InStrB(m_ResponseBody, ChrB(13) + ChrB(10))
    
        If p > 0 Then
    
            flag = StrConv(MidB(m_ResponseBody, 1, p - 1), vbUnicode)
    
            If Not (Len(Trim(flag)) > 6 Or Trim(flag) = "" Or Left(Trim(flag), 1) = "<") Then
                sizelength = CLng("&H" & flag)
                m_ResponseBody = MidB(m_ResponseBody, p + 2, sizelength)
            End If
            
        End If
    
    End If

    m_HDstring = ""
    m_SendData = ""
    RequestTimer.Enabled = False
    Winsock1.Close
    RaiseEvent OnRecvOver
End Sub

Private Sub Winsock1_Connect()
    RaiseEvent Connect
    Winsock1.SendData BuildHeader
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    On Error Resume Next
    
    Dim StatusCode As Integer
    Dim OldDataStart As Long
    
    Winsock1.PeekData buff(), vbArray Or vbByte, bytesTotal
    If Not HeaderEnd Then
        RequestTimer.Enabled = False
       
        OldDataStart = IIf(DataStart = 0, 1, DataStart)
        
        DataStart = InStrB(OldDataStart, buff, ChrB(13) + ChrB(10) + ChrB(13) + ChrB(10))
        m_ResponseHeader = StrConv(MidB(buff, OldDataStart, DataStart - OldDataStart), vbUnicode)
        
        StatusCode = CInt(Mid(m_ResponseHeader, 10, 3))
        
        RaiseEvent OnReveStatusCode(StatusCode)
'        Debug.Print StatusCode
'
'        Debug.Print m_ResponseHeader
        
        DataStart = DataStart + 4
        
        Select Case StatusCode
        Case "100" 'Continue
            
        Case "101" 'witchingProtocols
        Case "200" 'OK
            m_Content_Length = Val(Replace(GetResponseHeader("Content-Length"), ";", ""))
            HeaderEnd = True
            RaiseEvent OnReveHeaderOver
        Case "201" 'Created
        Case "202" 'Accepted
        Case "203" 'Non-AuthoritativeInformation
        Case "204" 'NoContent
        Case "205" 'ResetContent
        Case "206" 'PartialContent
        Case "300" 'MultipleChoices
        Case "301" 'MovedPermanently
        Case "302" 'Found
        Case "303" 'SeeOther
        Case "304" 'NotModified
        Case "305" 'UseProxy
        Case "307" 'TemporaryRedirect
        Case "400" 'BadRequest
        Case "401" 'Unauthorized
        Case "402" 'PaymentRequired
        Case "403" 'Forbidden
        Case "404" 'NotFound
        Case "405" 'MethodNotAllowed
        Case "406" 'NotAcceptable
        Case "407" 'ProxyAuthenticationRequired
        Case "408" 'RequestTime-out
        Case "409" 'Conflict
        Case "410" 'Gone
        Case "411" 'LengthRequired
        Case "412" 'PreconditionFailed
        Case "413" 'RequestEntityTooLarge
        Case "414" 'Request-URITooLarge
        Case "415" 'UnsupportedMediaType
        Case "416" 'Requestedrangenotsatisfiable
        Case "417" 'ExpectationFailed
        Case "500" 'InternalServerError
        Case "501" 'NotImplemented
        Case "502" 'BadGateway
        Case "503" 'ServiceUnavailable
        Case "504" 'GatewayTime-out
        Case "505" 'HTTPVersionnotsupported
        Case Else
        
        End Select
'        Dim ct As String
'        ct = LCase(Me.GetResponseHeader("Content-Type"))
'        If InStr(ct, "utf-8") > 0 And InStr(ct, "text/html") > 0 Then
'            m_ResponseHeader = CharsetConv(m_ResponseHeader, "UTF-8", "GB2312")
'        ElseIf InStr(ct, "utf-16") > 0 And InStr(ct, "text/html") > 0 Then
'            m_ResponseHeader = CharsetConv(m_ResponseHeader, "UTF-16", "GB2312")
'        End If
    
        'Debug.Print UBound(buff())
    

    End If
    
    RaiseEvent OnRecvDataLen(UBound(buff) + 1 - DataStart + 1)
End Sub

Private Sub Winsock1_Error(ByVal number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
On Error Resume Next
    Winsock1.Close
    RequestTimer.Enabled = False
    RaiseEvent Error(number, Description, Scode, Source, HelpFile, HelpContext, CancelDisplay)
End Sub

Public Property Get RequestUrl() As String
    RequestUrl = m_RequestUrl
End Property

Public Property Let RequestUrl(ByVal vNewValue As String)
    m_RequestUrl = vNewValue
    GetDomainPath (vNewValue)
End Property

Public Property Get SendData() As String
    SendData = m_SendData
End Property

Public Property Let SendData(ByVal vNewValue As String)
    m_SendData = vNewValue
End Property

Private Function BuildHeader() As String
    On Error Resume Next
    Dim rs As String
    
    If m_RequestType = TGET Then
        rs = "GET " & IIf(Trim(m_ProxyIP) = "", "", "http://" & m_Domain & IIf(m_RemotePort = 80, "", ":" & m_RemotePort)) & m_Path & IIf(Len(m_SendData) > 0, "?" & m_SendData, "") & " HTTP/" & Format((m_HTTPVer + 9) / 10, "0.0") & vbCrLf
    Else
        rs = "POST " & IIf(Trim(m_ProxyIP) = "", "", "http://" & m_Domain & IIf(m_RemotePort = 80, "", ":" & m_RemotePort)) & m_Path & " HTTP/" & Format((m_HTTPVer + 9) / 10, "0.0") & vbCrLf
    End If

    If InStr(LCase(m_HDstring), "host") = 0 Then
        Dim p As Long
        p = InStr(1, LCase(m_HDstring), "connection")
        If p Then
            m_HDstring = Left(m_HDstring, p - 1) & "Host: " & m_Domain & IIf(m_RemotePort <> 80, ":" & m_RemotePort, "") & vbCrLf & Mid(m_HDstring, p)
        Else
        
            p = InStr(1, LCase(m_HDstring), "user-agent")
            If p Then
            
                p = InStr(p + 1, m_HDstring, vbCrLf)
                p = p + 2
                
                m_HDstring = Left(m_HDstring, p - 1) & "Host: " & m_Domain & IIf(m_RemotePort <> 80, ":" & m_RemotePort, "") & vbCrLf & Mid(m_HDstring, p)
            Else
                m_HDstring = m_HDstring & "Host: " & m_Domain & IIf(m_RemotePort <> 80, ":" & m_RemotePort, "") & vbCrLf
            End If
        End If
    End If
    
    rs = rs & m_HDstring & vbCrLf
    
    If m_RequestType = TPOST Then
        rs = rs & m_SendData
    End If
    
    BuildHeader = rs
    Debug.Print rs
End Function

Public Property Get Http_Ver() As E_Http_Ver
    Http_Ver = m_HTTPVer
End Property

Public Property Let Http_Ver(ByVal vNewValue As E_Http_Ver)
    m_HTTPVer = vNewValue
End Property

Private Sub GetDomainPath(ByVal Url As String)
    On Error Resume Next
    Dim p1 As Integer
    Dim p2 As Integer
    Dim p3 As Integer

    m_RemotePort = 80
    
    If Not LCase(Left(Url, 7)) = "http://" Then
        Url = "http://" & Url
    End If
    
    p1 = InStr(Url, "//") + 2
    p2 = InStr(p1, Url, "/")
    p3 = InStr(p1, Url, ":")

    If p3 > 0 And p2 > p3 Then
        If IsNumeric(Mid(Url, p3 + 1, p2 - p3 - 1)) Then
            m_RemotePort = CLng(Mid(Url, p3 + 1, p2 - p3 - 1))
            
            If p2 > 0 Then
                m_Domain = Mid(Url, p1, p3 - p1)
                m_Path = Mid(Url, p2)
            Else
                m_Domain = Mid(Url, p1)
            End If
        End If
    Else
        If p2 > 0 Then
            m_Domain = Mid(Url, p1, p2 - p1)
            m_Path = Mid(Url, p2)
        Else
            m_Domain = Mid(Url, p1)
        End If
    End If
    
    If m_Path = "" Then m_Path = "/"
End Sub

Public Property Get ResponseHeader() As String
    ResponseHeader = m_ResponseHeader
End Property

Public Property Get ResponseBody() As Byte()
    ResponseBody = m_ResponseBody
End Property