VB Winsock HTTP POST GET表单提交

【实例截图】

【核心代码】

Option Explicit
'Download by http://www.NewXing.com
' we set this to true whil a connection is established
Private blnConnected As Boolean

' this function sends the HTTP request
Private Sub cmdSend_Click()
    Dim eUrl As URL
    
    Dim strMethod As String
    Dim strData As String
    Dim strPostData As String
    Dim strHeaders As String
    
    Dim strHTTP As String
    Dim X As Integer
    
    strPostData = ""
    strHeaders = ""
    strMethod = cboRequestMethod.List(cboRequestMethod.ListIndex)
    
    If blnConnected Then Exit Sub
    
    ' get the url
    eUrl = ExtractUrl(txtUrl.Text)
    
    If eUrl.Host = vbNullString Then
        MsgBox "Invalid Host", vbCritical, "ERROR"
    
        Exit Sub
    End If
    
    ' configure winsock
    winsock.Protocol = sckTCPProtocol
    winsock.RemoteHost = eUrl.Host
    
    If eUrl.Scheme = "http" Then
        If eUrl.Port > 0 Then
            winsock.RemotePort = eUrl.Port
        Else
            winsock.RemotePort = 80
        End If
    ElseIf eUrl.Scheme = vbNullString Then
        winsock.RemotePort = 80
    Else
        MsgBox "Invalid protocol schema"
    End If
    
    ' build encoded data the data is url encoded in the form
    ' var1=value&var2=value
    strData = ""
    For X = 0 To txtVariableName.Count - 1
        If txtVariableName(X).Text <> vbNullString Then
        
            strData = strData & URLEncode(txtVariableName(X).Text) & "=" & _
                            URLEncode(txtVariableValue(X).Text) & "&"
        End If
    Next X
    
    If eUrl.Query <> vbNullString Then
        eUrl.URI = eUrl.URI & "?" & eUrl.Query
    End If
    
    ' check if any variables were supplied
    If strData <> vbNullString Then
        strData = Left(strData, Len(strData) - 1)
        
        
        If strMethod = "GET" Then
            ' if this is a GET request then the URL encoded data
            ' is appended to the URI with a ?
            If eUrl.Query <> vbNullString Then
                eUrl.URI = eUrl.URI & "&" & strData
            Else
                eUrl.URI = eUrl.URI & "?" & strData
            End If
        Else
            ' if it is a post request, the data is appended to the
            ' body of the HTTP request and the headers Content-Type
            ' and Content-Length added
            strPostData = strData
            strHeaders = "Content-Type: application/x-www-form-urlencoded" & vbCrLf & _
                         "Content-Length: " & Len(strPostData) & vbCrLf
                         
        End If
    End If
            
    ' get any aditional headers and add them
    For X = 0 To txtHeaderName.Count - 1
        If txtHeaderName(X).Text <> vbNullString Then
        
            strHeaders = strHeaders & txtHeaderName(X).Text & ": " & _
                            txtHeaderValue(X).Text & vbCrLf
        End If
    Next X
    
    ' clear the old HTTP response
    txtResponse.Text = ""
    
    ' build the HTTP request in the form
    '
    ' {REQ METHOD} URI HTTP/1.0
    ' Host: {host}
    ' {headers}
    '
    ' {post data}
    strHTTP = strMethod & " " & eUrl.URI & " HTTP/1.0" & vbCrLf
    strHTTP = strHTTP & "Host: " & eUrl.Host & vbCrLf
    strHTTP = strHTTP & strHeaders
    strHTTP = strHTTP & vbCrLf
    strHTTP = strHTTP & strPostData

    txtRequest.Text = strHTTP
    
    winsock.Connect
    
    ' wait for a connection
    While Not blnConnected
        DoEvents
    Wend
    
    ' send the HTTP request
    winsock.SendData strHTTP
End Sub


Private Sub winsock_Connect()
    blnConnected = True
End Sub

' this event occurs when data is arriving via winsock
Private Sub winsock_DataArrival(ByVal bytesTotal As Long)
    Dim strResponse As String

    winsock.GetData strResponse, vbString, bytesTotal
    
    strResponse = FormatLineEndings(strResponse)
    
    ' we append this to the response box becuase data arrives
    ' in multiple packets
    txtResponse.Text = txtResponse.Text & strResponse
    
End Sub

Private Sub winsock_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)
    MsgBox Description, vbExclamation, "ERROR"
    
    winsock.Close
End Sub

Private Sub winsock_Close()
    blnConnected = False
    
    winsock.Close
End Sub

' this function converts all line endings to Windows CrLf line endings
Private Function FormatLineEndings(ByVal str As String) As String
    Dim prevChar As String
    Dim nextChar As String
    Dim curChar As String
    
    Dim strRet As String
    
    Dim X As Long
    
    prevChar = ""
    nextChar = ""
    curChar = ""
    strRet = ""
    
    For X = 1 To Len(str)
        prevChar = curChar
        curChar = Mid$(str, X, 1)
                
        If nextChar <> vbNullString And curChar <> nextChar Then
            curChar = curChar & nextChar
            nextChar = ""
        ElseIf curChar = vbLf Then
            If prevChar <> vbCr Then
                curChar = vbCrLf
            End If
            
            nextChar = ""
        ElseIf curChar = vbCr Then
            nextChar = vbLf
        End If
        
        strRet = strRet & curChar
    Next X
    
    FormatLineEndings = strRet
End Function

Private Sub Form_Load()
    cboRequestMethod.ListIndex = 0
    blnConnected = False
End Sub

' the code below has nothing to do with winsock or HTTP and deals only with the
' display and manipulation of controls
Private Sub cmdMoreHeaders_Click()
    Dim intNext As Integer
    Dim lngTop As Long
    
    ' find the next control
    intNext = txtHeaderName.Count
    
    ' find the next top
    lngTop = txtHeaderName(intNext - 1).Top   txtHeaderName(intNext - 1).Height   80
    
    ' add new controls
    Load lblHeaderName(intNext)
    Load txtHeaderName(intNext)
    Load lblHeaderValue(intNext)
    Load txtHeaderValue(intNext)
    
                                  
    With lblHeaderName(intNext)
        .Top = lngTop
        .Left = lblHeaderName(intNext - 1).Left
        .Visible = True
    End With
    
    With txtHeaderName(intNext)
        .Top = lngTop
        .Left = txtHeaderName(intNext - 1).Left
        .Visible = True
        .Text = ""
    End With
        
    With lblHeaderValue(intNext)
        .Top = lngTop
        .Left = lblHeaderValue(intNext - 1).Left
        .Visible = True
    End With
    
    With txtHeaderValue(intNext)
        .Top = lngTop
        .Left = txtHeaderValue(intNext - 1).Left
        .Visible = True
        .Text = ""
    End With
    
    ' set the new height of the controls container
    pbxHeaders.Height = txtHeaderName(intNext).Top   txtHeaderName(intNext).Height   80
    
    ' check if we should activate the scroll bar, ie: the outerbox
    ' is higher than the inner box
    If pbxHeaders.Height > pbxOHeaders.Height Then
        With vsbHeaders
            .Enabled = True
            .SmallChange = txtHeaderName(intNext).Height
            .LargeChange = pbxOHeaders.Height
            .Min = 0
            .Max = pbxHeaders.Height - pbxOHeaders.Height
            .Value = .Max
        End With
    End If
End Sub

Private Sub cmdMoreVariables_Click()
    Dim intNext As Integer
    Dim lngTop As Long
    
    ' find the next control
    intNext = txtVariableName.Count
    
    ' find the next top
    lngTop = txtVariableName(intNext - 1).Top   txtVariableName(intNext - 1).Height   80
    
    ' add new controls
    Load lblVariableName(intNext)
    Load txtVariableName(intNext)
    Load lblVariableValue(intNext)
    Load txtVariableValue(intNext)
    
                                  
    With lblVariableName(intNext)
        .Top = lngTop
        .Left = lblVariableName(intNext - 1).Left
        .Visible = True
    End With
    
    With txtVariableName(intNext)
        .Top = lngTop
        .Left = txtVariableName(intNext - 1).Left
        .Visible = True
        .TabIndex = txtVariableName(intNext - 1).TabIndex   2
        .Text = ""
    End With
        
    With lblVariableValue(intNext)
        .Top = lngTop
        .Left = lblVariableValue(intNext - 1).Left
        .Visible = True
    End With
    
    With txtVariableValue(intNext)
        .Top = lngTop
        .Left = txtVariableValue(intNext - 1).Left
        .TabIndex = txtVariableValue(intNext - 1).TabIndex   2
        .Visible = True
        .Text = ""
    End With
    
    ' set the new height of the controls container
    pbxVariables.Height = txtVariableName(intNext).Top   txtVariableName(intNext).Height   80
    
    ' check if we should activate the scroll bar, ie: the outerbox
    ' is higher than the inner box
    If pbxVariables.Height > pbxOVariables.Height Then
        With vsbVariables
            .Enabled = True
            .SmallChange = txtVariableName(intNext).Height
            .LargeChange = pbxOVariables.Height
            .Min = 0
            .Max = pbxVariables.Height - pbxOVariables.Height
            .Value = .Max
        End With
    End If
End Sub

Private Sub vsbHeaders_Change()
    pbxHeaders.Top = 0 - vsbHeaders.Value
End Sub

Private Sub vsbHeaders_Scroll()
    pbxHeaders.Top = 0 - vsbHeaders.Value
End Sub

Private Sub vsbVariables_Change()
    pbxVariables.Top = 0 - vsbVariables.Value
End Sub

Private Sub vsbVariables_Scroll()
    pbxVariables.Top = 0 - vsbVariables.Value
End Sub