Visual Basic 6.0 - WinInet

sample PLD Upload using WinInet API:

Module with WinInet declarations
'InternetOpen initialize use of WinInet functions
'use the two constants below to call the function 

'useragent constant
Public Const scUserAgent = "my PLD0200 application"
'use registry internetaccess settings 
Public Const INTERNET_OPEN_TYPE_PRECONFIG = 0

Public Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _
   (ByVal sAgent As String, _
    ByVal lAccessType As Long, _
    ByVal sProxyName As String, _
    ByVal sProxyBypass As String, _
    ByVal lFlags As Long) As Long


'InternetConnect returns a handle to the HTTP session
'use the two constants below to call the function 

'use http (instead of ftp or ...)
Public Const INTERNET_SERVICE_HTTP = 3

'default https port
Public Const INTERNET_DEFAULT_HTTPS_PORT = 443   

Public Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" _
   (ByVal InternetSession As Long, _
    ByVal sServerName As String, _
    ByVal nServerPort As Integer, _
    ByVal sUsername As String, _
    ByVal sPassword As String, _
    ByVal lService As Long, _
    ByVal lFlags As Long, _
    ByVal lContext As Long) As Long


'HttpOpenRequest returns an HTTP request handle
'use the constant below to call the function 

Public Const INTERNET_FLAG_SECURE = &H800000

Public Declare Function HttpOpenRequest Lib "wininet.dll" Alias "HttpOpenRequestA" _
   (ByVal hHttpSession As Long, _
    ByVal sVerb As String, _
    ByVal sObjectName As String, _
    ByVal sVersion As String, _
    ByVal sReferer As String, _
    ByVal something As Long, _
    ByVal lFlags As Long, _
    ByVal lContext As Long) As Long


'The HttpAddRequestHeaders function allows you to add or modify headers before sending them to the server
'use the constants below to call the function

'add a request header
Public Const HTTP_ADDREQ_FLAG_ADD = &H20000000
'replace a request header
Public Const HTTP_ADDREQ_FLAG_REPLACE = &H80000000

Public Declare Function HttpAddRequestHeaders Lib "wininet.dll" Alias "HttpAddRequestHeadersA" _
    (ByVal hHttpRequest As Long, _
    ByVal sHeaders As String, _
    ByVal lHeadersLength As Long, _
    ByVal lModifiers As Long) As Integer


'HttpSendRequest function sends a request
Public Declare Function HttpSendRequest Lib "wininet.dll" Alias "HttpSendRequestA" _
    (ByVal hHttpRequest As Long, _
    ByVal sHeaders As String, _
    ByVal lHeadersLength As Long, _
    ByVal sOptional As String, _
    ByVal lOptionalLength As Long) As Integer
    

'HttpQueryInfo allow access to the status line, response headers
'and entity header meta-information returned from the request
'use the constants below to call the function

Public Const HTTP_QUERY_RAW_HEADERS_CRLF = 22

Public Declare Function HttpQueryInfo Lib "wininet.dll" Alias "HttpQueryInfoA" _
    (ByVal hHttpRequest As Long, _
    ByVal lInfoLevel As Long, _
    ByRef sBuffer As Any, _
    ByRef lBufferLength As Long, _
    ByRef lIndex As Long) As Integer


'InternetReadFile will read the reponse body content.
Public Declare Function InternetReadFile Lib "wininet.dll" _
    (ByVal hFile As Long, _
    ByVal sBuffer As String, _
    ByVal lNumberOfBytesToRead As Long, _
    lNumberOfBytesRead As Long) As Integer


'InternetCloseHandle closes handles and frees resources associated with WinInet functions
Public Declare Function InternetCloseHandle Lib "wininet.dll" _
    (ByVal hInet As Long) As Integer

PLD Upload using WinInet:
Private Sub pld0200upload()


'-------------------- build pld0200 request message --------------------


'pld0200 request message part 1
Dim msgPart1 As String
msgPart1 = "AppVersion=1.0&AcceptUPSLicenseAgreement=YES&ResponseType=application/x-ups-pld&VersionNumber=V4R1&UserId=PLDDSTEST&Password=PLDDSTEST"

'pld0200 request message part 1 include header
msgPart1 = "Content-type: application/x-www-form-urlencoded" & vbCrLf & _
           "Content-length: " & Len(msgPart1) & vbCrLf & vbCrLf & _
           msgPart1


'pld0200 request message part 2
Dim pld0200file As String
Open "c:\temp\[filename]" For Binary Access Read As #1          'open pld0200file
 Input #1, pld0200file                                          'read pld0200file
Close #1                                                        'close pld0200file

'pld0200 request message part 2 include header
Dim msgPart2 As String
msgPart2 = "Content-type: application/x-ups-binary" & vbCrLf & _
           "Content-length: " & Len(pld0200file) & vbCrLf & vbCrLf & _
           pld0200file


'build complete pld0200request message
Dim PLD0200Request As String
PLD0200Request = "--BOUNDARY" & vbCrLf & _
                 msgPart1 & vbCrLf & vbCrLf & _
                 "--BOUNDARY" & vbCrLf & _
                 msgPart2 & vbCrLf & vbCrLf & _
                 "--BOUNDARY--"


'-------------------- create a SSL Connection --------------------

'declare all handles
Dim hInternetSession As Long            'InternetSession Handle 
Dim hInternetConnect As Long            'InternetConnect Handle 
Dim hHttpOpenRequest As Long            'HttpOpenRequest Handle 
Dim hHttpAddRequestHeaders As Long      'HttpAddRequestHeaders Handle 
Dim hHttpSendRequest As Integer         'HttpSendRequest ReturnValue 
Dim hInternetCloseHandle as Integer     'InternetCloseHandle ReturnValue 





'init InternetSession
hInternetSession = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)

'Http Session
hInternetConnect = InternetConnect(hInternetSession, "www.pld-certify.ups.com", INTERNET_DEFAULT_HTTPS_PORT, vbNullString, vbNullString, INTERNET_SERVICE_HTTP, 0, 0)
        
'Http Request 
hHttpOpenRequest = HttpOpenRequest(hInternetConnect, "POST", "/hapld/tos/kdwhapltos", "HTTP/1.0", vbNullString, 0, INTERNET_FLAG_SECURE, 0)
       
'Http RequestHeader 
Const sHeader As String = "Content-Type: multipart/mixed; boundary=BOUNDARY" & vbCrLf  'the PLD0200Request Content-Type Header
hHttpAddRequestHeaders = HttpAddRequestHeaders(hHttpOpenRequest, sHeader, Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)

'Send Request 
hHttpSendRequest = HttpSendRequest(hHttpOpenRequest, vbNullString, 0, PLD0200Request, Len(PLD0200Request))
                
'read response 
Dim bDoLoop As Boolean
Dim sReadBuffer As String * 2048
Dim lNumberOfBytesRead As Long
Dim fBuffer As String
bDoLoop = True
While bDoLoop
    sReadBuffer = vbNullString
    bDoLoop = InternetReadFile(hHttpOpenRequest, sReadBuffer, Len(sReadBuffer), lNumberOfBytesRead)
    fBuffer = fBuffer & Left$(sReadBuffer, lNumberOfBytesRead)
    If Not CBool(lNumberOfBytesRead) Then bDoLoop = False
        Debug.Print lNumberOfBytesRead
Wend

Dim PLD0200Response as String
PLD0200Response = fBuffer

'output the response
Debug.Print PLD0200Response

'Close InternetSession
hInternetCloseHandle = InternetCloseHandle (hInternetSession)


End Sub
Note: In a production environment it is recommend adding also some code for error handling



Copyright © 2003 United Parcel Service Deutschland Inc. & Co. OHG