<%
'***********************************************************************
' This version uses XML interface and requires a license key and userid/password
' VP-ASP 6.50
' March 10, 2004 Fix dimensions
'***************************************************************************
dim upsServices(2,50), servicecount
dim xmlDoc, xmlstring
dim itemsprice, frompostalcode
dim transactionid
dim xmlresult
dim chargesfound
Dim ServiceType, ServicePrice, Servicedate
'VP-ASP 6.50 - Handle UPS 2007 Web Services Changes
ignoreerror = True
'
Sub GetUPSRates (totalweight, dimensions)
If getupsconfig("xtrace",false, dbc)="Yes" then
debugwrite "Weight=" & totalweight & " Dest zip=" & shiptozip & " Dest City=" & shiptocity & " Dest state=" & shiptostate & " Dest country=" & shiptocountry
debugwrite "From zip=" & shipfromzip & " From City=" & shipfromcity & " From state=" & shipfromstate & " From country=" & shipfromcountry
end if
CreateXML totalweight, dimensions
SendXML
If serror="" then
AnalyzeUPSXML
end if
end sub
Sub CreateXML (totalweight,dimensions)
dim quantity
xmlstring=""
xmlstring=""
xmlstring=xmlstring & ""
xmlstring=xmlstring & "" & getupsconfig("AccessLicenceNum",true, dbc)& ""
xmlstring=xmlstring & "" & getupsconfig("Username",true, dbc) & ""
xmlstring=xmlstring & "" & getupsconfig("Password",true, dbc) & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & "Rating and Service"
xmlstring=xmlstring & "1.0001"
xmlstring=xmlstring & ""
xmlstring=xmlstring & "Rate"
xmlstring=xmlstring & "shop"
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & "" & getupsconfig("Pickuptype",false, dbc)& ""
xmlstring=xmlstring & ""
'VP-ASP 6.08a - Need to set customer classification code if PICKUPTYPE = 11
if getupsconfig("Pickuptype",false, dbc) = "11" AND shipfromcountry = "US" then
xmlstring=xmlstring & ""
xmlstring=xmlstring & "04"
xmlstring=xmlstring & ""
end if
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & "" & Shipfromzip & ""
xmlstring=xmlstring & "" & Shipfromcountry & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
'VP-ASP 6.09 - only send first 5 digits of post code if a US country
if ucase(shiptocountry) = "US" then
xmlstring=xmlstring & "" & left(Shiptozip,5) & ""
else
xmlstring=xmlstring & "" & Shiptozip & ""
end if
'xmlstring=xmlstring & "" & Shiptozip & ""
xmlstring=xmlstring & "" & shiptocountry & ""
if getupsconfig("ups_residentialind",false, dbc)="Yes" then
xmlstring=xmlstring & ""
end if
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & "" & Shipfromzip & ""
xmlstring=xmlstring & "" & Shipfromcountry & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & "11"
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & "" & getupsconfig("packagingType",false, dbc) & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & "" & getupsconfig("UPS_UnitofMeasurement",false, dbc) & ""
xmlstring=xmlstring & ""
AddDimensions dimensions
xmlstring=xmlstring & "" & length & ""
xmlstring=xmlstring & "" & Width & ""
xmlstring=xmlstring & "" & Height & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & "" & getupsconfig("UPS_WeightUnits",false, dbc) & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & "" & Totalweight & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
xmlstring=xmlstring & ""
'xmldoc=""
'xmldoc=""
'addxml ""
'addxml "" & getupsconfig("AccessLicenceNum",true, dbc)& ""
'addxml "" & getupsconfig("Username",true, dbc) & ""
'addxml "" & getupsconfig("Password",true, dbc) & ""
'addxml ""
'addxml ""
'addxml ""
'addxml ""
'addxml ""
'addxml "Rating and Service"
'addxml "1.0001"
'addxml ""
'addxml "Rate"
'addxml "shop"
'addxml ""
'addxml ""
'addxml "" & getupsconfig("Pickuptype",false, dbc)& ""
'addxml ""
'addxml ""
'addxml ""
'addxml ""
'addxml "" & shipfromCity & ""
'addxml "" & shipfromState & ""
'addxml "" & Shipfromzip & ""
'addxml "" & shipfromcountry & ""
'addxml ""
'addxml ""
'addxml ""
'addxml ""
'addxml "" & shiptoCity & ""
'addxml "" & shiptoState & ""
'addxml "" & Shiptozip & ""
'addxml "" & shiptocountry & ""
'if getupsconfig("UPS_Residentialind",false, dbc)="Yes" then
' addxml ""
'end if
'addxml ""
'addxml ""
'addxml ""
'addxml "11"
'addxml ""
'addxml ""
'addxml ""
'addxml "" & getupsconfig("packagingType",false, dbc) & ""
''addxml "Package"
'addxml ""
'AddDimensions
''addxml "Rate Shopping"
'addxml ""
'addxml ""
'addxml "" & getupsconfig("UPS_WeightUnits",false, dbc) & ""
'addxml ""
'addxml "" & Totalweight & ""
'addxml ""
'addxml ""
'addxml ""
'addxml ""
If getupsconfig("xtracexml",false, dbc)="Yes" then
debugwrite server.htmlencode(xmlstring)
end if
end Sub
'
Sub Addxml (fieldvalue)
xmldoc=xmldoc & fieldvalue
end sub
Sub AnalyzeUPSXML
If getupsconfig("xtracexml",false, dbc)="Yes" then
debugwrite "Data returned"
debugwrite server.htmlencode(xmlresult)
end if
dim worddrecord
pos=0
Workrecord= Replace(xmlresult,"<","~")
Workrecord= Replace(workrecord,">","~")
Parserecord workrecord, words, Wordcount,"~"
'debugwrite "wordcount=" & wordcount
wordloc=0
shippingcount=0
morewords=TRUE
do while morewords=TRUE
' debugwrite "wordloc=" & wordloc
' debugwrite "words=" & words(wordloc)
ProcessWord Words(wordloc)
wordloc=wordloc+1
If wordloc>wordcount then
morewords=false
end if
Loop
'debugwrite "shippingcount=" & shippingcount
If Statuscode<>"1" then
Serror="Error occurred getting shipping data. Status code=" & statuscode & "
"
if statuscode = "110208" then
Serror=Serror & "UPS can't ship to the country you have requested. Please go back and change your shipping selection.
"
else
Serror=Serror & Statusmessage & "
"
end if
'VP-ASP 6.50 - Handle UPS 2007 Web Services Changes
If statuscode = "110971" Then
serror = ""
End If
end if
end sub
Sub Processword (fieldname)
Dim tempoption, tempprice, ufieldname
dim code,shippingmethod
ufieldname=ucase(fieldname)
Select Case uFieldname
Case "RESPONSESTATUSCODE"
Statuscode=words(wordloc+1)
wordloc=wordloc+1
exit sub
Case "ERRORCODE"
Statuscode=words(wordloc+1)
wordloc=wordloc+1
exit sub
Case "RESPONSESTATUSDESCRIPTION"
StatusMessage=words(wordloc+1)
wordloc=wordloc+1
exit sub
Case "/RATEDSHIPMENT"
shippingcount=shippingcount+1
wordloc=wordloc+1
exit sub
Case "DELIVERYDATE"
ShippingDates(shippingcount)=words(wordloc+1)
wordloc=wordloc+1
exit sub
Case "RATEDSHIPMENT"
wordloc=wordloc+5
code=words(wordloc)
ServiceType=Convertshippingcode(code)
wordloc=wordloc+1
ChargesFound=false
exit sub
Case "/RATEDPACKAGE"
AddServicePrice servicetype, serviceprice, servicedate
wordloc=wordloc+1
exit sub
Case "TOTALCHARGES"
' tempoption=ShippingMethods(shippingcount)
wordloc=wordloc+6
If chargesfound=false then
ServicePrice=words(wordloc+1)
wordloc=wordloc+1
chargesfound=true
end if
exit sub
Case "/RATINGSERVICESELECTIONRESPONSE"
MoreWords=False
wordloc=wordloc+1
exit sub
Case "ERRORDESCRIPTION"
MoreWords=False
Statusmessage=statusmessage & words(wordloc+1) & "
"
exit sub
End select
end sub
Sub CombineShipping
if shippingcount=0 then exit sub
for i = 0 to shippingcount-1
'Shippingmethods(i)=shippingmethods(i) & ": Delivery date=" & ShippingDates(i) & shippingrates(i)
Shippingmethods(i)=shippingmethods(i) & " " & shippingrates(i)
next
end sub
Sub UPSSetupShippingMethods
dim i
servicecount=0
Addservice "01", "UPS Next Day Air"
Addservice "02", "UPS 2nd Day Air"
Addservice "03", "UPS Ground"
Addservice "07", "UPS Worldwide Express"
Addservice "08", "UPS Worldwide Expedited"
Addservice "11", "UPS Standard"
Addservice "12", "UPS 3-Day Select"
Addservice "13", "UPS Next Day Air Saver"
Addservice "14", "UPS Next Day Air Early AM"
Addservice "54", "UPS Worldwide Express Plus"
Addservice "59", "UPS 2nd Day Air AM"
Addservice "65", "UPS Express Saver"
for i = 0 to servicecount-1
TempPrices(i)=0
TempMethods(i)=upsservices(1,i)
next
tempmethodscount=servicecount
End sub
Sub AddService (scode,sname)
upsservices(0,servicecount)=scode
upsservices(1,servicecount)=sname
servicecount=servicecount+1
end sub
Function Convertshippingcode (scode)
dim i , shippingmethod
for i = 0 to servicecount-1
If upsservices(0,i)=scode then
shippingmethod=upsservices(1,i)
'debugwrite "code=" & scode & " " & shippingmethod
convertshippingcode=shippingmethod
exit function
end if
next
'debugwrite "No code found=" & scode
convertshippingcode="Unknown " & scode
end function
' Get total weight of products
'
Sub AddServicePrice (service, price, deliverydate)
dim i
price=csng(price)
'debugwrite "updating " & service & " " & price
For i = 0 to tempmethodscount-1
If service=TempMethods(i) then
TempPrices(i)=Tempprices(i)+price
If getupsconfig("xtrace",false,dbc)="Yes" then
debugwrite "updating " & service & " " & Price
end if
exit sub
end if
next
TempMethods(tempmethodscount)=Service
TempPrices(tempmethodscount)=price
tempmethodscount=tempmethodscount+1
If getupsconfig("xtrace",false, dbc)="Yes" then
debugwrite "adding " & service & " " & price
end if
end sub
Sub SendXML
dim itype,smethod, surl
sMethod = "POST"
if getupsconfig("testmode", false, dbc) = "Yes" then
sURL = getupsconfig("gatewaylocation_paymenttesting", false, dbc)
else
sURL = getupsconfig("gatewaylocation_payment", false, dbc)
end if
sURL = getupsconfig("gatewaylocation_paymenttesting", false, dbc)
Shopxmlhttp getupsconfig("xml", false, dbc), sURL, xmlstring, xmlresult, sMethod, serror
End sub
Sub SendXMLOLD
dim sMethod, xmlhttp, sURL
sMethod = "POST"
sURL = CPURL
'debugwrite server.htmlencode(xmldoc)
'debugwrite "url=" & sURL
set xmlhttp = Server.CreateObject ("Microsoft.XMLHTTP")
' set xmlhttp = Server.CreateObject ("MSXML2.ServerXMLHTTP.4.0")
xmlhttp.Open sMethod, sURL, false
XmlHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
xmlhttp.Send xmldoc
xmlresult=xmlhttp.responseText
'debugwrite "XML=" & server.htmlencode(xmlresult)
set xmlhttp = nothing
End sub
Sub AddDimensions (productdimensions)
shipdimensions = productdimensions
if shipdimensions = "" then shipdimensions = getupsconfig("dimensions", false, dbc)
If shipdimensions="" then shipdimensions = "4 4 4"
If getupsconfig("xtrace",false, dbc)="Yes" then
debugwrite "dimensions=" & shipdimensions
end if
dim words(10), wordcount
parserecord shipdimensions,words, wordcount, " "
length=words(0)
width=words(1)
height=words(2)
'If not isnumeric(length) then exit sub
'If not isnumeric(width) then exit sub
'If not isnumeric(height) then exit sub
If not isnumeric(length) then length = 4
If not isnumeric(width) then width = 4
If not isnumeric(height) then height = 4
'addxml ""
'addxml ""
'addxml "" & getupsconfig("UPS_UnitofMeasurement",false, dbc) & ""
'addxml ""
'addxml "" & length & ""
'addxml "" & width & ""
'addxml "" & height & ""
'addxml ""
end sub
%>