Option Explicit
'' this 3 lines to add scroll bar to listbox
Private Declare Function ShowScrollBar Lib "user32" (ByVal hwnd As Long, ByVal wBar As Long, _
ByVal bShow As Long) As Long
'Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const SB_HORIZONTAL = 0
' we set this to true whil a connection is established
Private blnConnected As Boolean
' this function sends the HTTP request
[B]Private Sub cmdSend_Click()[/B]
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
Command3_Click
End Sub
' transfer all urls i loop
[B]Private Sub Command1_Click()
Dim i As Long
For i = 0 To List2.ListCount - 1
List2.Selected(i) = True
txtVariableValue(0) = List2.List(i)
'MsgBox List2.List(i)
DoEvents
cmdSend_Click
Next
End Sub[/B]
Private Sub txtVariableValue_Change(Index As Integer)
cmdSend_Click
End Sub
'transfer url one by one function
Private Sub Command2_Click()
txtVariableValue(0) = List2.Text
End Sub
'writes the content of text box to a file
' this funcion needs to write to a text file
Private Sub Command3_Click()
'Dim Parser As New clsXMLParser
' Dim Node As clsXMLNode
'Dim Child As clsXMLNode
Dim fn As Long
'Dim i As Long
'Dim path As String
'Dim title As String
fn = FreeFile
Open "C:\file.txt" For Append As #fn
'Yes. Use Print #fn instead of Write #fn
'Write #fn, Text4.Text
Print #fn, txtResponse.Text
Close #fn
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
[B]List2.AddItem "item1"
List2.AddItem "item2"
List2.AddItem "item3"
List2.AddItem "item4"
List2.AddItem "item5"
List2.AddItem "item6"
List2.AddItem "item7"
List2.AddItem "item8"
List2.AddItem "item9"[/B]
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 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
