VB projects - UPS Component
Description: calculates UPS shipping costs
Minimum requirements: VB5, Internet connection
Download: source code
Project: ActiveX DLL
Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000 ' don't write this item to the cache
Const INTERNET_FLAG_RELOAD = &H80000000
Const INTERNET_FLAG_PRAGMA_NOCACHE = &H100
Private 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
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" _
(ByVal hInternetSession As Long, ByVal sURL As String, ByVal sHeaders As String, _
ByVal lHeadersLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, _
ByVal lpBuffer As String, ByVal dwNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long) _
As Boolean
Private Declare Function InternetCloseHandle Lib "wininet.dll" _
(ByVal hInet As Long) As Integer
Public Function Calculate(ByVal sType As String, ByVal sZipFrom As String, ByVal sZipTo _
As String, ByVal iWeight As Integer, ByVal iResidential As Integer) As String
On Error GoTo ErrHandler
Dim sURL As String
Dim hInet As Long 'inet handle
Dim hFile As Long 'url handle
'read file vars
Dim bDoLoop As Boolean
Dim bRet As Boolean
Dim sReadBuffer As String * 1024
Dim sBuffer As String
Dim lNumberOfBytesRead As Long
'connect
hInet = InternetOpen("UPS.CostCalculator", 0, vbNullString, vbNullString, 0)
If hInet <> 0 Then
' UPS types of delivery (for sType)
'==================================
' Next Day Air Early AM 1DM
' Next Day Air 1DA
' Next Day Air Saver 1DP
' 2nd Day Air AM 2DM
' 2nd Day Air 2DA
' 3 Day Select 3DS
' Ground GND
' Canada Standard STD
' Worldwide Express XPR
' Worldwide Express Plus XDM
' Worldwide Expedited XPD
'==================================
'more information on www.ups.com
sURL = "http://www.ups.com/using/services/rave/qcostcgi.cgi?" & _
"accept_UPS_license_agreement=yes&10_action=3&13_product=" & sType & _
"&14_origCountry=US&15_origPostal=" & sZipFrom & "&19_destPostal=" & _
sZipTo & "&22_destCountry=US&23_weight=" & iWeight & _
"&49_residential=" & iResidential
hFile = InternetOpenUrl(hInet, sURL, vbNullString, 0, INTERNET_FLAG_RELOAD Or _
INTERNET_FLAG_PRAGMA_NOCACHE, 0)
If CBool(hFile) Then
'read file
bDoLoop = True
While bDoLoop
sReadBuffer = vbNullString
bRet = InternetReadFile(hFile, sReadBuffer, 1024, lNumberOfBytesRead)
sBuffer = sBuffer & Left(sReadBuffer, lNumberOfBytesRead)
If Not CBool(lNumberOfBytesRead) Then bDoLoop = False
Wend
'output
Dim a: Dim i As Integer
a = Split(sBuffer, "%")
i = CInt(Right(a(0), 1))
Select Case i
Case 3 'single product
Calculate = a(10)
Case 4 'product range
Calculate = a(10)
Case 5 'error
Calculate = "Error. " & a(1)
Case 6 'warning
Calculate = "Warning. " & a(1)
Case Else
Calculate = "Unexpected response (" & i & ")"
End Select
Exit Function
Else
Calculate = TranslateErrorCode(Err.LastDllError)
End If
InternetCloseHandle hInet
Else
Calculate = "Failed to initialize INET"
End If
Exit Function
ErrHandler:
Calculate = "Error " & Err.Number & ": " & Err.Description
End Function
Private Function TranslateErrorCode(ByVal lErrorCode As Long) As String
Select Case lErrorCode
Case 0
Case 12001: TranslateErrorCode = "No more handles could be generated at this time"
Case 12002: TranslateErrorCode = "The request has timed out."
Case 12003: TranslateErrorCode = "An extended error was returned from the server."
Case 12004: TranslateErrorCode = "An internal error has occurred."
Case 12005: TranslateErrorCode = "The URL is invalid."
Case 12006: TranslateErrorCode = "The URL scheme could not be recognized, or is not supported."
Case 12007: TranslateErrorCode = "The server name could not be resolved."
Case 12008: TranslateErrorCode = "The requested protocol could not be located."
Case 12009: TranslateErrorCode = "A request to InternetQueryOption or InternetSetOption specified
an invalid option value."
Case 12010: TranslateErrorCode = "The length of an option supplied to InternetQueryOption or
InternetSetOption is incorrect for the type of option specified."
Case 12011: TranslateErrorCode = "The request option can not be set, only queried. "
Case 12012: TranslateErrorCode = "The Win32 Internet support is being shutdown or unloaded."
Case 12013: TranslateErrorCode = "The request to connect and login to an FTP server could not be
completed because the supplied user name is incorrect."
Case 12014: TranslateErrorCode = "The request to connect and login to an FTP server could not be
completed because the supplied password is incorrect. "
Case 12015: TranslateErrorCode = "The request to connect to and login to an FTP server failed."
Case 12016: TranslateErrorCode = "The requested operation is invalid. "
Case 12017: TranslateErrorCode = "The operation was canceled, usually because the handle on which the request
was operating was closed before the operation completed."
Case 12018: TranslateErrorCode = "The type of handle supplied is incorrect for this operation."
Case 12019: TranslateErrorCode = "The requested operation can not be carried out because the handle supplied
is not in the correct state."
Case 12020: TranslateErrorCode = "The request can not be made via a proxy."
Case 12021: TranslateErrorCode = "A required registry value could not be located. "
Case 12022: TranslateErrorCode = "A required registry value was located but is an incorrect type or has
an invalid value."
Case 12023: TranslateErrorCode = "Direct network access cannot be made at this time. "
Case 12024: TranslateErrorCode = "An asynchronous request could not be made because a zero context value
was supplied."
Case 12025: TranslateErrorCode = "An asynchronous request could not be made because a callback function has
not been set."
Case 12026: TranslateErrorCode = "The required operation could not be completed because one or more requests
are pending."
Case 12027: TranslateErrorCode = "The format of the request is invalid."
Case 12028: TranslateErrorCode = "The requested item could not be located."
Case 12029: TranslateErrorCode = "The attempt to connect to the server failed."
Case 12030: TranslateErrorCode = "The connection with the server has been terminated."
Case 12031: TranslateErrorCode = "The connection with the server has been reset."
Case 12036: TranslateErrorCode = "The request failed because the handle already exists."
Case Else: TranslateErrorCode = "Error details not available."
End Select
End Function
Sample Usage
In ASP:
---------
<%
Dim ups
Set ups = Server.CreateObject("UPS.Cost")
Response.Write "Shipping is $" & ups.Calculate("GND", "10026", "10209", 5, 1)
Set ups = Nothing
%>
In VB:
--------
Dim ups
Set ups = CreateObject("UPS.Cost")
MsgBox "Shipping is $" & ups.Calculate("GND", "10026", "10209", 55, 1)
|
