<% 'This code is copyright (c) Internet Business Solutions SL, all rights reserved. 'The contents of this file are protect under law as the intellectual property 'of Internet Business Solutions SL. Any use, reproduction, disclosure or copying 'of any kind without the express and written permission of Internet Business 'Solutions SL is forbidden. 'Author: Vince Reid, vince@virtualred.net numfirstclass=0 firstclasscost=0 sub sortshippingarray() for ssaindex2=0 to UBOUND(intShipping,2) intShipping(2,ssaindex2) = cDbl(intShipping(2,ssaindex2)) for ssaindex=1 to UBOUND(intShipping,2) if intShipping(3,ssaindex) AND cDbl(intShipping(2,ssaindex))" ' next end sub Private Sub ParseService(ochild, byRef packCost) Dim s, l For l = 0 To ochild.childNodes.length - 1 Set s = ochild.childNodes.Item(l) Select Case s.nodeName Case "Pounds" Case "Ounces" Case "MailType" Case "Country" Case "Postage" if s.firstChild.nodeValue > packCost then packCost = s.firstChild.nodeValue Case "SvcCommitments" Case "SvcDescription" Case "MaxDimensions" Case "MaxWeight" End Select Next End Sub Function ParseXMLOutput(sXML, international, byRef totalCost, byRef errormsg, byRef intShipping) Dim noError, nodeList, packCost, xmlDoc, e, i, j, k, l, n, t, t2, s2 noError = True totalCost = 0 packCost = 0 errormsg = "" gotxml=false on error resume next err.number=0 set xmlDoc = Server.CreateObject("MSXML2.DOMDocument") if err.number=0 then gotxml=true if NOT gotxml then err.number=0 set xmlDoc = Server.CreateObject("MSXML.DOMDocument") if err.number=0 then gotxml=true end if on error goto 0 xmlDoc.validateOnParse = False xmlDoc.loadXML (sXML) If xmlDoc.documentElement.nodeName = "Error" then 'Top-level Error noError = False Set nodeList = xmlDoc.getElementsByTagName("Error") Set n = nodeList.Item(0) For i = 0 To n.childNodes.length - 1 Set e = n.childNodes.Item(i) Select Case e.nodeName Case "Source" Case "Number" Case "Description" errormsg = e.firstChild.nodeValue Case "HelpFile" Case "HelpContext" End Select Next Else 'no Top-level Error Set nodeList = xmlDoc.getElementsByTagName("Package") For i = 0 To nodeList.length - 1 Set n = nodeList.Item(i) tmpArr = Split(n.getAttribute("ID"),"|") quantity = Int(tmpArr(1)) For j = 0 To n.childNodes.length - 1 Set e = n.childNodes.Item(j) If e.nodeName = "Error" Then 'Lower-level error noError = False For k = 0 To e.childNodes.length - 1 Set t = e.childNodes.Item(k) Select Case t.nodeName Case "Source" Case "Number" Case "Description" errormsg = t.firstChild.nodeValue Case "HelpFile" Case "HelpContext" End Select Next else Select Case e.nodeName Case "ZipOrigination" Case "ZipDestination" Case "Pounds" Case "Ounces" Case "Zone" Case "Postage" ' packCost = packCost + e.firstChild.nodeValue if international = "" then l = 0 do while (intShipping(0, l) <> thisService AND intShipping(0, l) <> "") l = l + 1 loop intShipping(0, l) = thisService if thisService="PARCEL" then intShipping(1, l) = "2-7 " & xxDays elseif thisService="EXPRESS" then intShipping(1, l) = "Overnight to most areas" elseif thisService="PRIORITY" then intShipping(1, l) = "1-2 " & xxDays elseif thisService="BPM" then intShipping(1, l) = "2-7 " & xxDays elseif thisService="Media" then intShipping(1, l) = "2-7 " & xxDays end if intShipping(2, l) = intShipping(2, l) + (e.firstChild.nodeValue * quantity) intShipping(3, l) = intShipping(3, l) + 1 end if Case "RestrictionCodes" Case "RestrictionDescription" Case "Service" if international <> "" then Set t2 = e.getElementsByTagName("SvcDescription") Set s2 = t2.Item(0) l = 0 do while (intShipping(0, l) <> s2.firstChild.nodeValue AND intShipping(0, l) <> "") l = l + 1 loop intShipping(0, l) = s2.firstChild.nodeValue Set t2 = e.getElementsByTagName("SvcCommitments") Set s2 = t2.Item(0) intShipping(1, l) = s2.firstChild.nodeValue Set t2 = e.getElementsByTagName("Postage") Set s2 = t2.Item(0) intShipping(2, l) = intShipping(2, l) + (s2.firstChild.nodeValue * quantity) intShipping(3, l) = intShipping(3, l) + 1 'Call ParseService(e,packCost) else thisService = e.firstChild.nodeValue end if End Select End If Next totalCost = totalCost + packCost packCost = 0 Next if iTotItems=numfirstclass then l = 0 do while (intShipping(0, l) <> "") l = l + 1 loop intShipping(0, l) = "FIRSTCLASS" intShipping(1, l) = "1-3 " & xxDays intShipping(2, l) = firstclasscost intShipping(3, l) = numfirstclass end if End If set xmlDoc = nothing ParseXMLOutput = noError end Function Function checkUPSShippingMeth(method, byRef discountsApply) retval = false for xx=0 to UBOUND(uspsmethods,2) if method=uspsmethods(0,xx) then retval=true discountsApply = uspsmethods(1,xx) exit for end if next checkUPSShippingMeth = retval End Function Function ParseUPSXMLOutput(xmlDoc, international, byRef totalCost, byRef errormsg, byRef errorcode, byRef intShipping) Dim noError, nodeList, packCost, e, i, j, k, l, n, t, t2, indexus noError = True totalCost = 0 packCost = 0 indexus = 0 l = 0 errormsg = "" Set t2 = xmlDoc.getElementsByTagName("RatingServiceSelectionResponse").Item(0) for j = 0 to t2.childNodes.length - 1 Set n = t2.childNodes.Item(j) if n.nodename="Response" then For i = 0 To n.childNodes.length - 1 Set e = n.childNodes.Item(i) if e.nodeName="ResponseStatusCode" then noError = Int(e.firstChild.nodeValue)=1 end if if e.nodeName="Error" then errormsg = "" For k = 0 To e.childNodes.length - 1 Set t = e.childNodes.Item(k) Select Case t.nodeName Case "ErrorCode" errorcode = t.firstChild.nodeValue Case "ErrorSeverity" if t.firstChild.nodeValue="Transient" then errormsg = "This is a temporary error. Please wait a few moments then refresh this page.
" & errormsg Case "ErrorDescription" errormsg = errormsg & t.firstChild.nodeValue End Select Next end if ' response.write "The Nodename is : " & e.nodeName & ":" & e.firstChild.nodeValue & "
" Next elseif n.nodename="RatedShipment" then wantthismethod=true For i = 0 To n.childNodes.length - 1 Set e = n.childNodes.Item(i) Select Case e.nodeName Case "Service" For k = 0 To e.childNodes.length - 1 Set t = e.childNodes.Item(k) if t.nodeName = "Code" then Select Case cStr(t.firstChild.nodeValue) Case "01" intShipping(0, l) = "UPS Next Day Air®" Case "02" intShipping(0, l) = "UPS 2nd Day Air®" Case "03" intShipping(0, l) = "UPS Ground" Case "07" intShipping(0, l) = "UPS Worldwide Express" Case "08" intShipping(0, l) = "UPS Worldwide Expedited" Case "11" intShipping(0, l) = "UPS Standard" Case "12" intShipping(0, l) = "UPS 3 Day Select®" Case "13" intShipping(0, l) = "UPS Next Day Air Saver®" Case "14" intShipping(0, l) = "UPS Next Day Air® Early A.M.®" Case "54" intShipping(0, l) = "UPS Worldwide Express Plus" Case "59" intShipping(0, l) = "UPS 2nd Day Air A.M.®" Case "65" intShipping(0, l) = "UPS Express Saver" End Select wantthismethod = checkUPSShippingMeth(t.firstChild.nodeValue, discntsApp) intShipping(4, l) = discntsApp end if Next Case "TotalCharges" For k = 0 To e.childNodes.length - 1 Set t = e.childNodes.Item(k) if t.nodeName = "MonetaryValue" then intShipping(2, l) = cDbl(t.firstChild.nodeValue) Next Case "GuaranteedDaysToDelivery" if e.childNodes.length > 0 then if e.firstChild.nodeValue="1" then intShipping(1, l) = "1 " & xxDay & intShipping(1, l) else intShipping(1, l) = e.firstChild.nodeValue & " " & xxDays & intShipping(1, l) end if end if Case "ScheduledDeliveryTime" if e.childNodes.length > 0 then intShipping(1, l) = intShipping(1, l) & " by " & e.firstChild.nodeValue End select Next if wantthismethod=true then intShipping(3, l) = true l = l + 1 else intShipping(1, l) = "" end if wantthismethod=true ' response.write "The RatedShipment is : " & n.nodeName & ":" & n.firstChild.nodeValue & "
" end if Next ParseUPSXMLOutput = noError end Function Function ParseCanadaPostXMLOutput(xmlDoc, international, byRef totalCost, byRef errormsg, byRef errorcode, byRef intShipping) Dim noError, nodeList, packCost, e, i, j, k, l, n, t, t2, indexus noError = True totalCost = 0 packCost = 0 indexus = 0 l = 0 errormsg = "" Set t2 = xmlDoc.getElementsByTagName("eparcel").Item(0) for j = 0 to t2.childNodes.length - 1 Set n = t2.childNodes.Item(j) if n.nodename="error" then noError = false For i = 0 To n.childNodes.length - 1 Set e = n.childNodes.Item(i) if e.nodeName="statusMessage" then errormsg = errormsg & e.firstChild.nodeValue elseif e.nodeName="statusCode" then errorcode = e.firstChild.nodeValue end if Next elseif n.nodename="ratesAndServicesResponse" then For i = 0 To n.childNodes.length - 1 Set e = n.childNodes.Item(i) if e.nodeName="product" then wantthismethod = checkUPSShippingMeth(e.getAttribute("id"), discntsApp) intShipping(4, l) = discntsApp wantthismethod=true For k = 0 To e.childNodes.length - 1 Set t = e.childNodes.Item(k) Select Case t.nodeName Case "name" intShipping(0, l) = t.firstChild.nodeValue Case "rate" intShipping(2, l) = cDbl(t.firstChild.nodeValue) Case "deliveryDate" if IsDate(t.firstChild.nodeValue) then numdays = DateValue(t.firstChild.nodeValue) - Date() intShipping(1, l) = numdays & " " & IIfVr(numdays<2,xxDay,xxDays) & intShipping(1, l) else intShipping(1, l) = t.firstChild.nodeValue & intShipping(1, l) end if Case "nextDayAM" if t.firstChild.nodeValue="true" then intShipping(1, l) = intShipping(1, l) & " AM" End select Next if wantthismethod=true then intShipping(3, l) = true l = l + 1 else intShipping(1, l) = "" end if wantthismethod=true end if next end if Next ParseCanadaPostXMLOutput = noError end Function function addDomestic(id,service,orig,dest,iWeight,quantity,container,size,machinable) Dim sXML sXML = "" pounds = Int(iWeight) ounces = round((iWeight-pounds)*16) if pounds=0 AND ounces=0 then ounces=1 if IsArray(uspsmethods) then for indexus=0 TO UBOUND(uspsmethods,2) if uspsmethods(0,indexus)="FIRSTCLASS" then if pounds=0 AND ounces<=13 then numfirstclass = numfirstclass + 1 firstclasscost = firstclasscost + ((ounces*0.23)+0.14) end if else sXML = sXML & "" sXML = sXML & ""&uspsmethods(0,indexus)&"" sXML = sXML & ""&orig&"" sXML = sXML & ""&left(dest, 5)&"" sXML = sXML & ""£s&"" sXML = sXML & ""&ounces&"" sXML = sXML & ""&container&"" sXML = sXML & ""&size&"" sXML = sXML & ""&machinable&"" sXML = sXML & "" end if next end if addDomestic = sXML end function function addInternational(id,iWeight,quantity,mailtype,country) Dim sXML pounds = Int(iWeight) ounces = round((iWeight-pounds)*16) if pounds=0 AND ounces=0 then ounces=1 sXML = "" sXML = sXML & ""£s&"" sXML = sXML & ""&ounces&"" sXML = sXML & ""&mailtype&"" sXML = sXML & ""&country&"" addInternational = sXML & "" end function function addUPSInternational(iWeight,adminUnits,packTypeCode,country,packcost) Dim sXML if iWeight < 0.1 then iWeight=0.1 sXML = ""&packTypeCode&"Package" sXML = sXML & "Rate Shopping"&adminUnits&""&iWeight&"" if abs(addshippinginsurance)=1 OR (abs(addshippinginsurance)=2 AND Trim(request.form("wantinsurance"))="Y") then if packcost > 50000 then packcost=50000 sXML = sXML & "" & countryCurrency & "" & FormatNumber(packcost,2,-1,0,0) & "" end if addUPSInternational = sXML & "" end function function addCanadaPostPackage(iWeight,adminUnits,packTypeCode,country,packcost,dimens) Dim sXML if iWeight < 0.1 then iWeight=0.1 if packtogether then thesize = 1 else thesize = 19 if productdimensions=true then proddims = split(dimens&"", "x") if UBOUND(proddims)>=0 then thelength = proddims(0) else thelength = thesize if UBOUND(proddims)>=1 then thewidth = proddims(1) else thewidth = thesize if UBOUND(proddims)>=2 then theheight = proddims(2) else theheight = thesize else thelength = thesize thewidth = thesize theheight = thesize end if addCanadaPostPackage = " 1 "&iWeight&" "&thelength&" "&thewidth&" "&theheight&" Goods for shipping rates selection " end function function USPSCalculate(sXML,international,byRef totalCost, byRef errormsg, byRef intShipping) Dim objHttp, i set objHttp = Server.CreateObject("Msxml2.ServerXMLHTTP") objHttp.open "POST", "http://production.shippingapis.com/ShippingAPI.dll", false on error resume next err.number=0 objHttp.Send "API="&international&"Rate&XML=" & Server.URLEncode(sXML) on error goto 0 If err.number <> 0 OR objHttp.status <> 200 Then errormsg = "Error, couldn't connect to USPS server" USPSCalculate = false Else saveLCID = Session.LCID Session.LCID = 1033 USPSCalculate = ParseXMLOutput(objHttp.responseText, international, totalCost, errormsg, intShipping) sortshippingarray() Session.LCID = saveLCID End If set objHttp = nothing end function function UPSCalculate(sXML,international,byRef totalCost, byRef errormsg, byRef intShipping) Dim objHttp, i set objHttp = Server.CreateObject("Msxml2.ServerXMLHTTP") objHttp.open "POST", "https://www.ups.com/ups.app/xml/Rate", false objHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded" ' response.write Replace(Replace(sXML,"<")&"

---

" on error resume next err.number=0 objHttp.Send sXML on error goto 0 If err.number <> 0 OR objHttp.status <> 200 Then errormsg = "Error, couldn't connect to UPS server" UPSCalculate = false Else saveLCID = Session.LCID Session.LCID = 1033 ' response.write Replace(Replace(objHttp.responseText,"<")&"

---

" UPSCalculate = ParseUPSXMLOutput(objHttp.responseXML, international, totalCost, errormsg, errorcode, intShipping) sortshippingarray() if errorcode = 111210 then errormsg = "The destination zip / postal code is invalid." Session.LCID = saveLCID End If set objHttp = nothing end function function CanadaPostCalculate(sXML,international,byRef totalCost, byRef errormsg, byRef intShipping) Dim objHttp, i set objHttp = Server.CreateObject("Msxml2.ServerXMLHTTP") if canadaposttest = TRUE then objHttp.open "POST", "http://206.191.4.228:30000", false else objHttp.open "POST", "http://216.191.36.73:30000", false end if objHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded" ' response.write Replace(Replace(sXML,"<")&"

---

" on error resume next err.number=0 objHttp.Send sXML on error goto 0 If err.number <> 0 OR objHttp.status <> 200 Then errormsg = "Error, couldn't connect to CanadaPost server" UPSCalculate = false Else saveLCID = Session.LCID Session.LCID = 1033 ' response.write Replace(Replace(objHttp.responseText,"<")&"

---

" CanadaPostCalculate = ParseCanadaPostXMLOutput(objHttp.responseXML, international, totalCost, errormsg, errorcode, intShipping) sortshippingarray() Session.LCID = saveLCID End If set objHttp = nothing end function %>