<%
' Copyright (C) 1998-2005 CyberStrong Internet Services, Inc. All Rights Reserved
'
' This file has been seeded with unique information at point of sale and
' is traceable to its purchaser.
'
' Your license agreement forbids the removal of this notice.
' sUPS.asp - UPS Live Rate Lookup
Class clsRateGatewayUPS
Private mPostData, mServiceTable, mXMLConfigString
' Constructor -----------------------------------------------------
Private Sub Class_Initialize()
Name = "UPS Live Shipping Rate Lookup"
Installed = True
Trace = False
HelpFileName = ""
mPostData = ""
Version = 1.3
Set mServiceTable = CreateObject("Scripting.Dictionary")
mXMLConfigString = ReadFile("\shipping\sUPS.xml")
Call XMLToTable(mXMLConfigString, "Service", "Code", "Description", mServiceTable)
PreviewFields = GetPreviewFieldList(mXMLConfigString)
End Sub
' Destructor ------------------------------------------------------
Private Sub Class_Terminate()
mPostData = ""
End Sub
' Public Properties -----------------------------------------------
Public Name ' The full name of this gateway
Public Installed ' True for real gateway, False for gateway hook
Public Trace ' True to enable debug messages
Public HelpFileName ' Help for this gateway stored here
Public Version ' Class version number
Public PreviewFields ' Comma separated list of fields required for shipping preview
' Public Methods --------------------------------------------------
' AddRates() - Add rates for this shipping method to master rate table ...
Public Sub AddRates(ByVal argShipToInfo, ByVal argCart, ByRef argShipChoiceTable, ByRef argErrorMsg)
Dim oHTTP, HTTPReply, HTTPReplyString, TokenList
Dim oXMLDoc, oError, RatedShipment, RatedShipmentList
Dim Key, Service, ServiceCode, Rate, Delivery, DeliveryDays, DeliveryDate
On Error Resume Next
' This gateway will not process zero weight shipments ...
If (argShipToInfo.OrderShipUnits <= 0) Then Exit Sub
mPostData = ""
mAddToPost ""
mAddToPost ""
mAddToPost " $(LicenceNo)"
mAddToPost " $(UserID)"
mAddToPost " $(Password)"
mAddToPost ""
mAddToPost ""
mAddToPost ""
mAddToPost " "
mAddToPost " "
mAddToPost " Rating and Service"
mAddToPost " 1.0001"
mAddToPost " "
mAddToPost " rate"
mAddToPost " shop"
mAddToPost " "
mAddToPost " "
mAddToPost " $(PickupType)"
mAddToPost " "
mAddToPost " "
mAddToPost " "
mAddToPost " "
mAddToPost " $(OrigCity)"
mAddToPost " $(OrigState)"
mAddToPost " $(OrigPostalCode)"
mAddToPost " $(OrigCountryISOA2)"
mAddToPost " "
mAddToPost " "
mAddToPost " "
mAddToPost " "
mAddToPost " $(DestCity)"
mAddToPost " $(DestState)"
mAddToPost " $(DestPostalCode)"
mAddToPost " $(DestCountryISOA2)"
mAddToPost IIF(argShipToInfo.ResidentialDelivery, " ", "")
mAddToPost " "
mAddToPost " "
mAddToPost " "
mAddToPost " "
mAddToPost " $(UnitOfMeasurement)"
mAddToPost " $(UnitOfMeasurement)"
mAddToPost " "
mAddToPost " $(Weight)"
mAddToPost " "
mAddToPost " "
mAddToPost " 01"
mAddToPost " "
mAddToPost " "
mAddToPost " $(PackageType)"
mAddToPost " "
mAddToPost " "
mAddToPost " $(UnitOfMeasurement)"
mAddToPost " $(UnitOfMeasurement)"
mAddToPost " "
mAddToPost " $(Weight)"
mAddToPost " "
mAddToPost " $(PackageOversize)"
mAddToPost " "
mAddToPost " "
mAddToPost " $(InsuredValueCode)"
mAddToPost " $(InsuredValue)"
mAddToPost " "
mAddToPost " "
mAddToPost " "
mAddToPost " "
mAddToPost " "
mAddToPost ""
TokenList = Split(argShipToInfo.UPSLogin, "/")
' Test for missing login info ...
If (UBound(TokenList) <> 2) Then
Call Log(0, "sUPS.asp: Missing login component.")
Exit Sub
End If
' Substitute our values in post string ...
mSubPost "LicenceNo", TokenList(0)
mSubPost "UserID", TokenList(1)
mSubPost "Password", TokenList(2)
mSubPost "OrigCity", argShipToInfo.OrigCity
mSubPost "OrigState", argShipToInfo.OrigState
mSubPost "OrigPostalCode", argShipToInfo.OrigPostalCode
mSubPost "OrigCountryISOA2", argShipToInfo.OrigCountryISOA2
mSubPost "DestCity", argShipToInfo.DestCity
mSubPost "DestState", argShipToInfo.DestState
mSubPost "DestPostalCode", argShipToInfo.DestPostalCode
mSubPost "DestCountryISOA2", argShipToInfo.DestCountryISOA2
mSubPost "PickupType", argShipToInfo.UPSPickupType
mSubPost "PackageType", argShipToInfo.UPSPackageType
mSubPost "PackageOversize", argShipToInfo.UPSPackageOversize
mSubPost "UnitOfMeasurement", argShiptoInfo.UPSUnitsOfWeight
mSubPost "InsuredValueCode", argShiptoInfo.OrigCountryISOA2
mSubPost "InsuredValue", IIF(argShipToInfo.Insured, FormatNumber(argShipToInfo.OrderTotal, 2, True, False, 0), "0.00")
mSubPost "Weight", FormatNumber(argShipToInfo.OrderShipUnits / _
IIF(Trim(LCase(argShipToInfo.UPSUnitsOfWeight)) = "lbs", CDbl(16.00), CDbl(35.27)), _
1, True, False, 0)
If (Trace) Then
wl("Request:
" & Server.HTMLEncode(mPostData) & "
")
End If
' Request a rate schedule ...
Err.Clear
Set oHTTP = CreateHTTPObject()
If (Err) Then
Call Log(0, "sUPS.asp: CreateHTTPObject(): Failed (" & UsingHTTPObject & ")")
Exit Sub
End If
' Post the request ...
oHTTP.Open "POST", "https://www.ups.com/ups.app/xml/Rate", False
oHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
oHTTP.Send Replace(mPostData, vbCrLf, "")
' Get the reply ...
HTTPReplyString = oHTTP.ResponseText
If (Trace) Then
wl("
HTTPReply: " & Replace(Server.HTMLEncode(HTTPReplyString), ">", ">
") & "
")
End If
' Confirm that we received a reply ...
If (Trim(HTTPReplyString) = "") Then
Call Log(0, "UPS Server returned null reply.")
End If
' Parse response string ...
Set oXMLDoc = Server.CreateObject("Msxml2.DOMDocument")
oXMLDoc.LoadXML(HTTPReplyString)
' Look for top level errors first ...
Set oError = oXMLDoc.GetElementsByTagName("Error")
If (oError.Length > 0) Then
Set oError = oXMLDoc.GetElementsByTagName("ErrorDescription")
argErrorMsg = argErrorMsg & "UPS: " & oError.Item(0).Text & " "
Set oError = Nothing
Set oXMLDoc = Nothing
Exit Sub
End If
' Parse reply from UPS server ...
Set RatedShipmentList = oXMLDoc.GetElementsByTagName("RatedShipment")
For Each RatedShipment in RatedShipmentList
ServiceCode = GetXMLNodeValue(RatedShipment, "Service")
DeliveryDays = GetXMLNodeValue(RatedShipment, "GuaranteedDaysToDelivery")
DeliveryDate = GetXMLNodeValue(RatedShipment, "ScheduledDeliveryTime")
Rate = GetXMLNodeValue(RatedShipment, "TotalCharges/MonetaryValue")
Service = mServiceTable(ServiceCode)
Select Case CInt("0" + DeliveryDays)
Case 0 :
Case 1 : Delivery = "Next Day"
Case Else : Delivery = DeliveryDays & " Days"
End Select
If (DeliveryDate <> "") Then
Delivery = Delivery & " By " & DeliveryDate
End If
' Save rate in table for customer selection ...
Key = "UPS:" & Service
Set argShipChoiceTable.Item(Key) = New clsShipChoice
argShipChoiceTable.Item(Key).Carrier = "UPS"
argShipChoiceTable.Item(Key).Service = "UPS:" & Service
argShipChoiceTable.Item(Key).ServiceCode = ServiceCode
argShipChoiceTable.Item(Key).Rate = Rate
argShipChoiceTable.Item(Key).Delivery = Delivery
Next
Set oXMLDoc = Nothing
Set RatedShipmentList = Nothing
End Sub
' Supports() - Returns TRUE if this gateway has the given (optional) capability
Public Function Supports(ByVal argCapability)
Supports = False
End Function
' Install() - Install this class into eShop.
Public Sub Install()
Dim i, ServiceCode, ServiceCodeList, rs, SQL
' Update shipping method table with allowable methods for this carrier ...
set rs = Server.CreateObject("ADODB.Recordset")
SQL = "SELECT * FROM ShippingMethods WHERE Gateway = 'UPS' AND System = 'Yes'"
rs.Open SQL, Conn, adOpenKeyset, adLockOptimistic
' Install default records for new users only ...
If (rs.RecordCount = 0) Then
rs.Close
Conn.Execute("DELETE FROM ShippingMethods WHERE Gateway = 'UPS' AND System = 'Yes'")
rs.Open "ShippingMethods", Conn, adOpenKeyset, adLockOptimistic
ServiceCodeList = mServiceTable.Keys
i = 1
For Each ServiceCode In ServiceCodeList
rs.AddNew
rs("ShippingMethod") = "UPS:" & mServiceTable(ServiceCode)
rs("ShipperCode") = ServiceCode
rs("Gateway") = "UPS"
rs("ShippingOrderBy") = "UPS" & ZeroFill(i, 2)
rs("ShippingMethodActive") = "Yes"
rs("ShippingAllowFree") = "No"
rs("System") = "Yes"
rs("LastUpdated") = Date()
rs.Update : i = i + 1
Next
Else
rs.Close
End If
set rs = Nothing
' Make parms visible in parms table ...
Call EnableParms("ups")
End Sub
' Dump() - Dump internal class variables for debug.
Public Sub Dump()
End Sub
' Test() - Class self test.
Public Sub Test()
End Sub
' Private Functions/Subs ------------------------------------------
' mAddToPost() - Add parmeter to post template ...
Private Sub mAddToPost(ByVal argParmValue)
If (argParmValue <> "") Then
mPostData = mPostData & argParmValue & vbCrLF
End If
End Sub
' mSubPost() - Substitute our value in post template ...
Private Sub mSubPost(ByVal argParmWhat, ByVal argParmWith)
mPostData = Replace(mPostData, "$(" & argParmWhat & ")", argParmWith)
End Sub
End Class
' Register gateway on loading ...
Set FeatureInstalled.Item("Rate Gateway:UPS") = New clsRateGatewayUPS
' Revision History ...
' 1.0 Initial Release
' 1.1 Moved InsuredValue tag from Shipment Service Options to Package Service Options
' 1.2 Changed parsing rule for "TotalCharges"
' 1.3 Changed parsing method for all UPS returned fields.
%>