Comments

This class simplifies using the Wininet Library to implement HTTP requests. Using this class it's a piece of cake to POST Url-Encoded form data to a server.

This code has been revised (28 Aug 2003): There was an error in the URLEncode function where a hexed value was not necessarily 2 digits long. The SendRequest function has also been updated to download the request directly from the server by default (Reload).

This code has been revised (02 Sep 2003): The While loop for reading the returned data in SendRequest had faulty logic (changed to While r and (Read <> 0))

This code has been revised (29 Nov 2003): Updated OpenHTTP to both add the option to connect to any port and the ability to authenticate using basic authentication (plain text).

What it can't do

• Return Progress Messages
• Return Detailed Error Messages
• Return the Response Header

Reference

HTTPClass Properties

Fields [= Value]

Read-Write

Return Type is a String

HTTPClass Methods

URLEncode (Data)

Return Type is a String Value

SendRequest (File[, Method][, Referer][, Reload])

Return Type is a String Value

CloseHTTP

OpenHTTP (Server[, Port][, UserName][, Password])

Return Type is a Boolean Value

Usage

Add HTTPClass.cls to your project

   'Example: POST a Form

   Dim h As HTTPClass

   Set h = New HTTPClass

   h.Fields("Username") = "Andrew"
   h.Fields("Email") = "andrew@paradoxes.info"
   h.Fields("Password") = "Secret"

   If h.OpenHTTP("www.paradoxes.info") Then
      Debug.Print h.SendRequest("test.asp", "POST")
   End If

   Set h = Nothing

   'Example: Download an Image to file

   Dim fh As Long
   Dim h As HTTPClass

   Set h = New HTTPClass

   If h.OpenHTTP("www.paradoxes.info") Then
      fh = FreeFile
      Open App.Path & "\vbcode.jpg" For Binary As #fh
      Put #fh, , h.SendRequest("/pics/vbcode.jpg", "GET")
      Close #fh
   End If

   Set h = Nothing

The Code

HTTPClass.cls

Option Explicit

Public Enum ePort
   INTERNET_DEFAULT_HTTP_PORT = 80
   INTERNET_DEFAULT_HTTPS_PORT = 443
End Enum

Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_SERVICE_HTTP = 3

Private Const INTERNET_FLAG_PRAGMA_NOCACHE = &H100
Private Const INTERNET_FLAG_KEEP_CONNECTION = &H400000
Private Const INTERNET_FLAG_SECURE = &H800000
Private Const INTERNET_FLAG_FROM_CACHE = &H1000000
Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Private Const INTERNET_FLAG_RELOAD = &H80000000

Private Const BUFFER_LENGTH As Long = 1024

Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _
(ByVal Agent As String, ByVal AccessType As Long, ByVal ProxyName As String, _
ByVal ProxyBypass As String, ByVal Flags As Long) As Long
Private Declare Function InternetConnect Lib "wininet.dll" Alias _
"InternetConnectA" (ByVal hInternetSession As Long, ByVal ServerName As String, _
ByVal ServerPort As Integer, ByVal UserName As String, ByVal Password As _
String, ByVal Service As Long, ByVal Flags As Long, ByVal Context As Long) As _
Long
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As _
Long) As Boolean

Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hConnect As _
Long, ByVal Buffer As String, ByVal NumberOfBytesToRead As Long, _
NumberOfBytesRead As Long) As Boolean

Private Declare Function HttpOpenRequest Lib "wininet.dll" Alias _
"HttpOpenRequestA" (ByVal hHttpSession As Long, ByVal Verb As String, ByVal _
ObjectName As String, ByVal Version As String, ByVal Referer As String, ByVal _
AcceptTypes As Long, ByVal Flags As Long, Context As Long) As Long
Private Declare Function HttpSendRequest Lib "wininet.dll" Alias _
"HttpSendRequestA" (ByVal hHttpRequest As Long, ByVal Headers As String, ByVal _
HeadersLength As Long, ByVal sOptional As String, ByVal OptionalLength As Long) _
As Boolean

Private hHTTP As Long
Private hConnection As Long

Private Const FIELDS_BUFFER_LENGTH As Long = 10
Private Const FIELDS_NAME_INDEX As Long = 0
Private Const FIELDS_VALUE_INDEX As Long = 1

Private DontEncode(255) As Boolean

Private FieldCount As Long
Private mFields() As String

Public Property Let Fields(Name As String, Value As String)

   mFields(FIELDS_VALUE_INDEX, GetFieldIndex(Name, True)) = Value

End Property

Public Property Get Fields(Name As String) As String

   Dim l As Long

   l = GetFieldIndex(Name, False)
   If l > -1 Then
      Fields = mFields(FIELDS_VALUE_INDEX, l)
   End If

End Property

Public Function OpenHTTP(Server As String, Optional Port As ePort = _
INTERNET_DEFAULT_HTTP_PORT, Optional UserName As String, Optional Password As _
String) As Boolean

   CloseHTTP

   hHTTP = InternetOpen("HTTP Client", INTERNET_OPEN_TYPE_DIRECT, UserName, _
   Password, 0)
   If hHTTP <> 0 Then
      hConnection = InternetConnect(hHTTP, Server, INTERNET_DEFAULT_HTTP_PORT, _
      UserName, Password, INTERNET_SERVICE_HTTP, 0, 0)
      If hConnection <> 0 Then
         OpenHTTP = True
      Else
         InternetCloseHandle hHTTP
         hHTTP = 0
      End If
   End If

End Function

Public Sub CloseHTTP()

    If hConnection <> 0 Then
      InternetCloseHandle hConnection
    End If

    hConnection = 0

    If hHTTP Then
      InternetCloseHandle hHTTP
    End If

    hHTTP = 0

End Sub

Public Function SendRequest(ByVal File As String, Optional Method As String = _
"GET", Optional Referer As String, Optional Reload As Boolean = True) As String

   Dim hRequest As Long
   Dim r As Boolean
   Dim Buffer As String
   Dim Header As String
   Dim Request As String
   Dim POSTData As String
   Dim Response As String
   Dim Read As Long
   Dim Flags As Long

   Method = UCase$(Method)
   Request = BuildRequest
   Buffer = Space$(BUFFER_LENGTH)

   If Len(Request) > 0 Then
      If Method = "POST" Then
         Header = "Content-Type: application/x-www-form-urlencoded"
         POSTData = Request
      Else
         File = File & "?" & Request
      End If
   End If

   If Reload Then
      Flags = Flags Or INTERNET_FLAG_PRAGMA_NOCACHE Or INTERNET_FLAG_RELOAD
   End If

   hRequest = HttpOpenRequest(hConnection, Method, File, "HTTP/1.1", "", 0, _
   Flags, 0)
   If hRequest <> 0 Then
      If HttpSendRequest(hRequest, Header, Len(Header), POSTData, _
      Len(POSTData)) Then
         r = InternetReadFile(hRequest, Buffer, BUFFER_LENGTH, Read)
         While r And (Read <> 0)
            Response = Response & Left$(Buffer, Read)
            r = InternetReadFile(hRequest, Buffer, BUFFER_LENGTH, Read)
         Wend
      End If
      InternetCloseHandle hRequest
   End If

   SendRequest = Response

End Function

Private Function GetFieldIndex(Name As String, Optional Add As Boolean) As Long

   Dim l As Long

   For l = 0 To FieldCount - 1
      If StrComp(Name, mFields(FIELDS_NAME_INDEX, l), vbTextCompare) = 0 Then
         GetFieldIndex = l
         Exit Function
      End If
   Next

   If Add Then
      If FieldCount = UBound(mFields, 2) Then
         ReDim Preserve mFields(1, UBound(mFields, 2) + FIELDS_BUFFER_LENGTH)
      End If
      mFields(FIELDS_NAME_INDEX, FieldCount) = Name
      GetFieldIndex = FieldCount
      FieldCount = FieldCount + 1
   Else
      GetFieldIndex = -1
   End If

End Function

Private Function BuildRequest() As String

   Dim l As Long
   Dim s As String

   For l = 0 To FieldCount - 1
      s = s & URLEncode(mFields(FIELDS_NAME_INDEX, l)) & "=" & _
      URLEncode(mFields(FIELDS_VALUE_INDEX, l)) & "&"
   Next

   If Len(s) > 0 Then
      BuildRequest = Left$(s, Len(s) - 1)
   End If

End Function

Public Function URLEncode(Data As String) As String

   Dim l As Long
   Dim b() As Byte
   Dim s As String
   Dim c As String

   b = Data
   'This is fine for encoding small strings
   'To encode large ones I suggest you replace s with the String Class
   For l = 0 To UBound(b) Step 2
      If DontEncode(b(l)) Then
         s = s & Chr(b(l))
      Else
         c = Hex(b(l))
         While Len(c) < 2
            c = "0" & c
         Wend
         s = s & "%" & c
      End If
   Next

   URLEncode = s

End Function

Private Sub Class_Initialize()

   Dim l As Long

   ReDim mFields(1, FIELDS_BUFFER_LENGTH)

   For l = Asc("0") To Asc("9")
      DontEncode(l) = True
   Next
   For l = Asc("a") To Asc("z")
      DontEncode(l) = True
   Next
   For l = Asc("A") To Asc("Z")
      DontEncode(l) = True
   Next

End Sub

Private Sub Class_Terminate()

   Erase mFields

End Sub

Downloads

  HTTPClass.zip - contains: HTTPClass.cls (1.9 kb)

© Copyright Notice

Unless otherwise stated, the code on this site is Copyright to Andrew McMillan. You may use this code in your projects (both commercial and non-commercial) but you are not permitted to republish this code in any form without the Author's prior consent.

The code on this site is supplied "as is" and no claims are made as to its soundness. The Author claims no responsibility for or liability from use of said source code.