<%
' 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.
' Shared file for shipping rate gateways.
' Shipping gateway classes ...
' clsShipInfo - Holds shipping info for pass to shipping gateway.
Class clsShipInfo
Dim OrigCity
Dim OrigState
Dim OrigPostalCode
Dim OrigCountryName
Dim OrigCountryISOA2
Dim OrigCountryISOA3
Dim OrigCountryISONum
Dim DestCity
Dim DestState
Dim DestPostalCode
Dim DestCountryName
Dim DestCountryISOA2
Dim DestCountryISOA3
Dim DestCountryISONum
Dim OrderQtyCount
Dim OrderTotal
Dim OrderTotalCalcShip
Dim OrderShipUnits
Dim ResidentialDelivery
Dim Insured
Dim FlatRate
Dim UPSLogin
Dim UPSPickupType
Dim UPSPackageType
Dim UPSPackageOversize
Dim UPSUnitsOfWeight
Dim USPSLogin
Dim USPSContainer
Dim USPSPackageSize
Dim USPSMachinable
Dim CanPostLogin
Dim CanPostPackageSize
Dim FedExLogin
Dim FedExMeterNum
Dim FedExPickupType
Dim FedExPackageType
Dim DHLLogin
End Class
' clsShipChoice - Holds a single returned shipping rate.
Class clsShipChoice
Dim Carrier
Dim Service
Dim ServiceCode
Dim Rate
Dim Free
Dim Delivery
End Class
' DisplayPreviewShippingPanel() - Display shipping charge preview panel ...
Public Sub DisplayPreviewShippingPanel()
wl("
")
wl("
")
wl("
")
wl("Shipping Rate Preview")
wl("
")
wl("
")
wl("
")
wl("
")
wl("
")
wl("
")
wl("Click here to preview our shipping rates.")
wl("
")
wl("
")
wl("
")
End Sub
' ScanForShipPreviewFields() - Scan all active shipping classes for fields
' - required for shipping preview.
Public Function ScanForShipPreviewFields()
Dim rs, SQL, Key, PreviewFields
SQL = "SELECT DISTINCT Gateway FROM ShippingMethods " & _
"WHERE {fn LCase(ShippingMethodActive)} = 'yes'"
Set rs = Server.CreateObject("ADODB.Recordset")
rs.Open SQL, Conn, adOpenKeyset, adLockOptimistic
Do While (Not rs.EOF)
Key = "Rate Gateway:" & Trim(rs("Gateway"))
If (FeatureInstalled.Exists(Key)) Then
If (Not strIsEmpty(FeatureInstalled(Key).PreviewFields)) Then
PreviewFields = PreviewFields & FeatureInstalled(Key).PreviewFields & ","
End If
End If
rs.MoveNext
Loop
rs.Close : Set rs = Nothing
'Remove trailing comma if present ...
ScanForShipPreviewFields = ReplaceRegEx(PreviewFields, ",$", "", "")
End Function
' GetPreviewFieldList() - Extracts from carrier XML file ...
' - Called by all shipping classes.
Public Function GetPreviewFieldList(ByVal argXMLString)
Dim XMLDoc, Element, ElementList
' Create an XML document from file ...
Set XMLDoc = Server.CreateObject("Msxml2.DOMDocument")
XMLDoc.LoadXML(argXMLString)
' Parse reply ...
Set ElementList = XMLDoc.GetElementsByTagName("ShippingServices")
For Each Element in ElementList
GetPreviewFieldList = GetXMLNodeValue(Element, "PreviewFieldList")
Next
' Clean up ...
Set ElementList = Nothing : Set XMLDoc = Nothing
End Function
' GetShippingCost - Get Shipping Costs...
Public Function GetShippingCost(ByVal oShippingRates, ByVal ShippingMethod)
Dim KeyList
' Set fallback value ...
GetShippingCost = "0"
' Recover shipping cost from previously loaded internal shipping table ...
If (oShippingRates.Exists(ShippingMethod)) Then
GetShippingCost = oShippingRates(ShippingMethod).Rate
Else
' First pass, Shipping method unknown ...
KeyList = oShippingRates.Keys
GetShippingCost = oShippingRates(KeyList(0)).Rate
End If
End Function
' GetTransitTime - Get Transit Time...
Public Function GetTransitTime(ByVal oShippingRates, ByVal ShippingMethod)
Dim KeyList
' Set fallback value ...
GetTransitTime = ""
' Recover shipping cost from previously loaded internal shipping table ...
If (oShippingRates.Exists(ShippingMethod)) Then
GetTransitTime = oShippingRates(ShippingMethod).Delivery
Else
' First pass, Shipping method unknown ...
KeyList = oShippingRates.Keys
GetTransitTime = oShippingRates(KeyList(0)).Delivery
End If
End Function
' LoadShippingRates() - Poll all shipping rate objects.
' - Collect rates to global internal table.
Public Sub LoadShippingRates(ByRef oShippingRates, _
ByVal argCountry, ByVal argState, ByVal argCity, ByVal argPostalCode)
Dim rsShipMethods, oShipToInfo, ErrorMsg, RateTest, MinEnforced
Dim PercentAdd, AmountAdd, ShippingMethod, ShippingMethodList
Dim Key, QtyCount, i, SQL
Set oShippingRates = CreateObject("Scripting.Dictionary")
Set oShipToInfo = New clsShipInfo
' Get totals needed for shipping calculations ...
iSubtotal = 0 : iShipUnits = 0 : iSubTotalForShipping = 0 : QtyCount = 0
For i = 1 to iCount
' Accumulate subtotal...
If (aryCart(cartUnitPrice, i) <> "") Then
iSubTotal = iSubtotal + aryCart(cartTotalPrice, i)
End If
' Accumulate shipping units and total for ByOrderValue shipping for qualified products...
If (LCase(aryCart(cartProductShipsFree, i)) <> "yes") Then
If (aryCart(cartUnitPrice, i) <> "") Then
iSubTotalForShipping = iSubTotalForShipping + aryCart(cartTotalPrice, i)
End If
If ((cstShippingUnitsEnabled) AND ((aryCart(cartShippingUnits, i) & "") <> "")) Then
iShipUnits = iShipUnits + (aryCart(cartShippingUnits, i) * aryCart(cartItemQuantity, i))
End If
' Accunulate total number of items in basket...
QtyCount = QtyCount + aryCart(cartItemQuantity, i)
End If
Next
' Prepare to accumulate shipping rates...
With oShipToInfo
.OrigCity = cstOriginCity
.OrigState = cstOriginState
.OrigPostalCode = cstOriginCode
.OrigCountryName = cstOriginCountry
.OrigCountryISOA2 = GetCountryCode(cstOriginCountry, "ISOA2")
.OrigCountryISOA3 = GetCountryCode(cstOriginCountry, "ISOA3")
.OrigCountryISONum = GetCountryCode(cstOriginCountry, "ISONum")
.DestCity = argCity
.DestState = UCase(argState)
.DestPostalCode = Replace(argPostalCode, " ", "")
.DestCountryName = argCountry
.DestCountryISOA2 = GetCountryCode(argCountry, "ISOA2")
.DestCountryISOA3 = GetCountryCode(argCountry, "ISOA3")
.DestCountryISONum = GetCountryCode(argCountry, "ISONum")
.OrderTotal = iSubTotal
.OrderTotalCalcShip = iSubTotalForShipping
.OrderQtyCount = QtyCount
.OrderShipUnits = CDbl(iShipUnits) + CDbl(cstShipWeightAdd)
.ResidentialDelivery = cstUseResidentialRate
.Insured = cstInsured
.FlatRate = cstFlatRateShippingEnabled
.UPSLogin = cstUPSLogin
.UPSPickupType = cstUPSPickupType
.UPSPackageType = cstUPSContainer
.UPSPackageOversize = cstUPSPackageOversize
.UPSUnitsOfWeight = cstUPSUnitsofWeight
.USPSLogin = cstUSPSLogin
.USPSContainer = cstUSPSContainer
.USPSPackageSize = cstUSPSPackageSize
.USPSMachinable = cstUSPSMachinable
.FedExLogin = cstFedExLogin
.FedExMeterNum = cstFedExMeterNum
.FedExPickupType = cstFedExPickupType
.FedExPackageType = cstFedExPackageType
.CanPostLogin = cstCanPostLogin
.CanPostPackageSize = cstCanPostPackageSize
.DHLLogin = ""
End With
Set rsShipMethods = Server.CreateObject("ADODB.Recordset")
' Request rates from all active rate gateways ...
SQL = "SELECT DISTINCT Gateway FROM ShippingMethods " & _
"WHERE {fn LCase(ShippingMethodActive)} = 'yes'"
rsShipMethods.Open SQL, Conn, adOpenKeyset, adLockOptimistic
Do While (Not rsShipMethods.EOF)
Key = "Rate Gateway:" & Trim(rsShipMethods("Gateway"))
If (FeatureInstalled.Exists(Key)) Then
ErrorMsg = ""
Call FeatureInstalled(Key).AddRates(oShipToInfo, aryCart, oShippingRates, ErrorMsg)
If (ErrorMsg <> "") Then
ShipperErrorMsg = ShipperErrorMsg & "Shipper: " & ErrorMsg & " "
End If
End If
rsShipMethods.MoveNext
Loop
rsShipMethods.Close
' Find and mark methods eligible for free shipping. Apply shipping rules...
SQL = "SELECT * FROM ShippingMethods WHERE ({fn LCase(ShippingMethodActive)} = 'yes') AND ({fn LCase(ShippingAllowFree)} = 'yes')"
rsShipMethods.Open SQL, Conn, adOpenKeyset, adLockOptimistic
Do While (Not rsShipMethods.EOF)
' Test for free shipping eligibility, set rate to zero for eligible methods ...
If (oShippingRates.Exists(Trim(rsShipMethods("ShippingMethod")))) Then
If ( _
(cstFreeShippingEnabled) OR _
((CDbl(cstShipFreeOverAmount) <> 0.00) AND (iSubTotal >= CDbl(cstShipFreeOverAmount))) _
) Then
oShippingRates(Trim(rsShipMethods("ShippingMethod"))).Rate = 0.00
oShippingRates(Trim(rsShipMethods("ShippingMethod"))).Free = True
End If
End If
rsShipMethods.MoveNext
Loop
rsShipMethods.Close
' Remove rates disabled by shipping method rules...
If (IsInstalled("Feature:Shipping Method Rules")) Then
SQL = "SELECT * FROM ShippingMethods WHERE {fn LCase(ShippingMethodActive)} = 'yes'"
rsShipMethods.Open SQL, Conn, adOpenKeyset, adLockOptimistic
Do While (Not rsShipMethods.EOF)
If (oShippingRates.Exists(Trim(rsShipMethods("ShippingMethod")))) Then
With oShipToInfo
If (Not FeatureInstalled("Feature:Shipping Method Rules").isRuleMatch( _
rsShipMethods("ShippingDestRuleName"), .DestCountryName, .DestState, .DestCity, .DestPostalCode, .OrderShipUnits)) Then
oShippingRates.Remove Trim(rsShipMethods("ShippingMethod"))
End If
End With
End If
rsShipMethods.MoveNext
Loop
rsShipMethods.Close
End If
' Remove any remaining rates not enabled in the ShippingMethods Table
ShippingMethodList = oShippingRates.Keys
For Each ShippingMethod In ShippingMethodList
If (Not isShippingMethodEnabled(ShippingMethod)) Then
oShippingRates.Remove(ShippingMethod)
End If
Next
' Final check. Do we have a useable rate? If not, add an appropriate default...
RateTest = _
IIF(iShipUnits = 0, "Y", "N") & _
IIF(iSubTotalForShipping = 0, "Y", "N") & _
IIF(oShippingRates.Count = 0, "Y", "N") & _
IIF(cstShipMinCharge = 0, "Y", "N")
Select Case RateTest
Case "NNNN" : MinEnforced = True
Case "NNNY" : MinEnforced = False
Case "NNYN" : MinEnforced = False : Call AddShippingRate(oShippingRates, "No Shipping Options")
Case "NNYY" : MinEnforced = False : Call AddShippingRate(oShippingRates, "No Shipping Options")
Case "NYNN" : MinEnforced = True
Case "NYNY" : MinEnforced = False
Case "NYYN" : MinEnforced = True : Call AddShippingRate(oShippingRates, "Best Method")
Case "NYYY" : MinEnforced = False : Call AddShippingRate(oShippingRates, "Best Method")
Case "YNNN" : MinEnforced = True
Case "YNNY" : MinEnforced = False
Case "YNYN" : MinEnforced = False : Call AddShippingRate(oShippingRates, "No Shipping Options")
Case "YNYY" : MinEnforced = False : Call AddShippingRate(oShippingRates, "No Shipping Options")
Case "YYNN" : MinEnforced = True
Case "YYNY" : MinEnforced = False
Case "YYYN" : MinEnforced = True : Call AddShippingRate(oShippingRates, "Best Method")
Case "YYYY" : MinEnforced = False : Call AddShippingRate(oShippingRates, "Best Method")
End Select
' Mark up all returned rates by amount and percent...
SQL = "SELECT * FROM ShippingMethods WHERE {fn LCase(ShippingMethodActive)} = 'yes'"
rsShipMethods.Open SQL, Conn, adOpenKeyset, adLockOptimistic
Do While (Not rsShipMethods.EOF)
Key = Trim(rsShipMethods("ShippingMethod"))
If (oShippingRates.Exists(Key)) Then
If (oShippingRates(Key).Rate <> 0) Then
If (cstShipPerMethodAdd) Then
PercentAdd = IIF(isNullOrZero(rsShipMethods("ShippingPercentAdd")), cstShipPercentAdd, rsShipMethods("ShippingPercentAdd"))
AmountAdd = IIF(isNullOrZero(rsShipMethods("ShippingAmountAdd")), cstShipAmountAdd, rsShipMethods("ShippingAmountAdd"))
Else
PercentAdd = cstShipPercentAdd
AmountAdd = cstShipAmountAdd
End If
oShippingRates(Key).Rate = _
(CDbl(oShippingRates(Key).Rate) * (1.0 + (CDbl(PercentAdd) / 100.0))) + _
CDbl(AmountAdd)
End If
End If
rsShipMethods.MoveNext
Loop
rsShipMethods.Close : Set rsShipMethods = Nothing
' Apply shipping rate min/max rules...
ShippingMethodList = oShippingRates.Keys
For Each ShippingMethod in ShippingMethodList
If (cstShipMinCharge <> 0.00 And MinEnforced) Then oShippingRates(ShippingMethod).Rate = Max(oShippingRates(ShippingMethod).Rate, cstShipMinCharge)
If (cstShipMaxCharge <> 0.00) Then oShippingRates(ShippingMethod).Rate = Min(oShippingRates(ShippingMethod).Rate, cstShipMaxCharge)
Next
End Sub
' AddShippingRate() - Add a shipping rate to the rate list...
Public Sub AddShippingRate(ByRef argShippingRates, ByVal argServiceType)
Dim Key
Key = argServiceType
Set argShippingRates(Key) = New clsShipChoice
argShippingRates(Key).Carrier = "None"
argShippingRates(Key).Service = argServiceType
argShippingRates(Key).ServiceCode = "None"
argShippingRates(Key).Rate = 0.00
argShippingRates(Key).Delivery = ""
End Sub
Private Function isShippingMethodEnabled(ByVal argShippingMethod)
Dim SQL, rs
SQL = "SELECT ShippingMethod FROM ShippingMethods " & _
"WHERE ShippingMethod = '" & argShippingMethod & "' AND {fn LCase(ShippingMethodActive)} = 'yes'"
Set rs = Server.CreateObject("ADODB.Recordset")
rs.Open SQL, Conn, adOpenKeyset, adLockOptimistic
isShippingMethodEnabled = CBool(rs.RecordCount = 1)
rs.Close : Set rs = Nothing
End Function
%>
