<%option explicit%> <% '**************************************************************** ' this routine interface to UPS to obtain Real Time Shipping ' Rocksalt International has no association with UPS. ' UPS may withdraw or alter this service at any time. ' VP-ASP 6,0 ' Jan 1, 2006 fix shipmethod being null ' Jan 3, 2006 getupsconfig was missing from xcheckindividualproductfield at line 382 '************************************************************************** dim DefaultDestzip, DefaultDestCountry, Defaultdestcity, defaultdeststate dim defaultshipzip dim defaultshipcity, defaultshipstate, defaultshippostcode, defaultshipcountry dim defaultdimensions, productdimensions dim Totalweight ' Dim shiptozip, shiptocountry, shiptocity, shiptostate Dim shipfromzip, shipfromcountry, shipfromcity, shipfromstate dim shipweight, shipdimensions ' Dim TempMethods(50), TempPrices(50), temptables(50), tempzones(50) Dim TempMethodscount, ShippingCodes(50) Dim ShippingMethods(50) '------------ ' 20/10/2005 ' Fix for dual currency shipping '------------ dim shippingvalues(50), shippingprices(50) '------------ Dim ShippingCount dim shipmethodtype dim sDestZip Dim sAction Dim dbc Dim scartitem Dim arrCart Dim sRowColor dim httpresp dim sitms dim IndividualQuantity dim IndivProductvalue sRowColor=xTableRowColor Dim length, width, height, weight, quantity dim shiptotalcost, shiptotalquantity, shiptotalfeatureweight, shiptotalweight '********************************************************************** ' First get UPS real Time shipping values ' Display a form for customer to select from ' When customer selects method and price, save those as VP-ASP ' Session variables and continue to shopcreateorder.asp '************************************************************************* sAction=request("action") if saction="" then sAction=request("action.x") end if setsess "CurrentURL","upsxmlrealtime.asp" setsess "FollowonURL","shopcreateorder.asp" ' force login to come back to us setsess "smprice","" ' no price setsess "ShipMethod","" ' no type if Saction<>"" then SetupShippingValues ' Got answer from customer ' continue to shopcreateorder is in above subroutine end if ShopPageHeader GetShippingPrices 'Logic to get Shipping Prices DisplayForm ' ask customer what he wants to do ShopPageTrailer '********************************************************************** ' Selection has been set up for us in shipmethods ' Simply display the form '********************************************************************** Sub DisplayForm shopopendatabase myconn Dim SelectString If Serror="" Then shopwriteheader getlang("LangShippingSelect") shopwriteheader getlang("LangProductWeight") & " " & Getsess("totalweight") & " " & getupsconfig("UPS_Weightunits", false, myconn) & "
" %>

" onsubmit="return checkSelected()"> <% dim i, rowcolor, sChecked rowcolor = 1 for i = 0 to shippingcount-1 'VP-ASP 6.50 - make sure first option is selected if no option is chosen if i=0 then sChecked = " checked=""checked""" else sChecked = "" end if if rowcolor = 1 then rowcolor = 0%> <% else rowcolor = 1%> <% end if 'VP-ASP 6.50 - make sure first option is selected if no option is chosen%> <%next%>

<%shopwriteheader getlang("LangShippingMethod")%>		<%shopwriteheader "Price"%>
/>	<%=shippingmethods(i)%>	<%=shippingprices(i)%>

<% If Getconfig("xbuttoncontinue")="" Then Response.Write("") else Response.Write("") end if addwebsessform %>

NOTE: These fees do not necessarily represent UPS published rates and may include charges levied by the store owner. UPS, UPS brandmark, and the Color Brown are trademarks of United Parcel Service of America, Inc. All Rights Reserved.

<% setsess "shipIsUPS", true else shopwriteerror SError Serror="" end if shopclosedatabase myconn end sub '************************************************************* ' Customer has theoretically select something froma drop down list ' Make sure they have selected something '************************************************************* Sub SetupShippingValues dim shipmethodtype dim shipmethod dim shipCost 'VP-ASP 6.50 - precautionary security fix shipmethodtype=cleanchars(request("shipmethodtype")) ParseOption ShipMethodType, ShipMethod, ShipCost 'VP-ASP 6.50 - ensure selected item isn't "select" or blank If ShipMethodType = getlang("LangCommonSelect") OR ShipMethodType = "" Then sError = sError & getlang("LangShippingError") & "
" exit sub End If setsess "ShipMethod",Shipmethod & "
Weight=" & Getsess("Totalweight") setsess "smprice",ShipCost If Serror="" then responseredirect "shopcreateorder.asp" end if end sub '***************************************************************** ' Get Shipping Prices ' This is we we go through the products and get actual shipping costs '********************************************************************* Sub GetShippingPrices ShopOpendatabaseP DBC CalculateShippingdetails dbc,shiptotalWeight,shiptotalfeatureweight, shiptotalcost, shiptotalquantity Totalweight=shiptotalweight If Totalweight=0 then HandleZeroWeight shopclosedatabase dbc exit sub end if totalweight=0 SetDefaultvalues ' Set default Shipping Values UPSSetupShippingMethods ProcessCartItems ' go throught cart to get shipping cost If serror="" then FormatMethods end if ShopCloseDatabase Dbc End Sub '************************************************************************ ' This is thae main program logic ' Go through each product. ' If individual packaging is used calculate on an individual basis ' If delivery address, calculate on an individual basis ' If Drop shipping from a supplier, calculate on an individual basis '*************************************************************************** Sub ProcessCartItems dim rsitem,prodid, prodquantity, prodprice, prodname, prodfeatures dim i, tempzip dim weight dim supplierid, singleweight Dim calculate, deliveryarray singleweight=0 scartItem = getsess("cartcount") arrCart = getsessa("cartarray") ' go through all products calculate=false For i = 1 to scartItem prodid=arrCart(cProductid,i) prodname= arrCart(cProductname,i) Prodquantity=arrCart(cQuantity,i) ProdPrice=arrCart(cUnitPrice, i) prodfeatures=arrCart(cProductFeatures, i) Deliveryarray=arrcart(cDelivery,i) Individualquantity=prodquantity calculate=CheckDeliveryFree (dbc, prodid) If calculate=true then Getproductweight prodid, prodquantity, weight, supplierid, productdimensions, prodfeatures Calculate=CheckDeliverySelf(deliveryArray) If Calculate=false Then ' individual calculation If weight>0 then If getupsconfig("xIndividualPackages",false, dbc)="Yes" then dim ii, indivweight for ii = 1 to individualquantity indivweight = (weight/individualquantity) MakeShippingDefaults ' set defaults for from and to address GetShippingzip supplierid, Deliveryarray GetUPSRates indivweight, productdimensions TotalWeight=indivweight+totalweight next else MakeShippingDefaults ' set defaults for from and to address GetShippingzip supplierid, Deliveryarray ' data is passed as global variables ' shopto... ' shipfrom... GetUPSRates weight, productdimensions TotalWeight=weight+totalweight end if end if else singleweight=singleweight+ weight end if end if Next If singleweight>0 then if getupsconfig("xtrace",false, dbc)="Yes" then debugwrite "Singleweight=" & singleweight end if prodquantity=1 ' productdimensions="" MakeShippingDefaults 'VP-ASP 6.09 - updated IF statement so that autoseparate works better 'If getupsconfig("Xautoseparatepackages",false, dbc)="No" or weight< getupsconfig("xautoseparateWeight",false, dbc) then If getupsconfig("Xautoseparatepackages",false, dbc)="No" or clng(singleweight)< clng(getupsconfig("xautoseparateWeight",false, dbc)) then GetUPSRates singleweight, productdimensions else Autoseparatepackages singleweight, shiptozip, shiptocountry, shipfromzip end if totalweight=totalweight+singleweight end if setsess "Totalweight",Totalweight end sub '************************************************************************* ' Destination Zip could be from default or Delivery array '************************************************************************* Sub GetShippingzip (supplierid, Deliveryarray) Dim tempzip, tempcountry, tempcity, tempstate shipfromzip=defaultshipzip If getupsconfig("xtrace",false, dbc)="Yes" then Debugwrite "supplierid=" & supplierid end if GetSupplierzip supplierid, shipfromzip If isarray(deliveryarray) then tempzip=deliveryarray(dpostcode) tempcountry=deliveryarray(dcountry) tempcity= deliveryarray(dcity) tempstate=deliveryarray(dstate) If Tempzip<>"" then shiptozip=Tempzip shiptostate=tempstate shiptocity=tempcity end if If tempcountry<>"" Then Convertcountries tempcountry shiptocountry=tempcountry end if end if end sub '**************************************************************** ' need to see if package can be group with our products ' or needs to be shipped individually ' Individually if ' specifically individualpackages=Yes ' or check on product and individual product field said do it separately ' or xdeliveryshipping=Yes and there is a delivery address '***************************************************************** Function CheckDeliverySelf (deliveryArray) ' Returns tru if to calculate this product Dim DeliveryType CheckDeliverySelf=True If getupsconfig("xIndividualPackages",false, dbc)="Yes" then CheckDeliverySelf=False exit function end if If getupsconfig("xcheckIndividualProduct",false, dbc)="Yes" and IndivProductvalue<>"" then CheckDeliverySelf=False exit function end if If getconfig("Xdeliveryshipping")<>"Yes" then exit function If isarray(deliveryarray) then Deliverytype=Deliveryarray(dDeliveryType) If Deliveryarray(dDeliveryType)<>getlang("LangDeliverySelf") then CheckDeliverySelf=false end if end if end function '******************************************************************* ' Setup default Shipping Zip Code and country ' Setup Default from Zip Code '********************************************************************* Sub SetDefaultvalues DefaultDestZip = Getsess("shipzip") If DefaultDestZip = "" Then DefaultDestZip = Getsess("Postcode") end if DefaultDestcountry=getsess("Shipcountry") if defaultDestcountry=""then defaultdestcountry=Getsess("Country") end if if defaultdestcountry="" then defaultdestcountry="US" else ConvertCountries defaultDestCountry end if defaultdestcity=GetSess("shiptown") If defaultdestcity="" then defaultdestcity=Getsess("City") end if defaultdeststate=Getsess("shipstate") If defaultdeststate="" then defaultdeststate=Getsess("state") end if defaultshipzip=getupsconfig("xMerchantPostCode",false, dbc) defaultshipstate=getupsconfig("xMerchantState",false, dbc) defaultshipcity=getupsconfig("xMerchantCity",false, dbc) defaultshipcountry=getupsconfig("xMerchantCountry",false, dbc) ' defaultdimensions=getupsconfig("UPS_Dimensions",false, dbc) end sub ' '********************************************************************* ' Get product weight and supplierid '******************************************************************** Sub Getproductweight (catalogid, prodquantity, weight, supplierid, productdimensions, prodfeatures) dim sql, rs, tempdimensions, featureweight, totalfeatureweight weight=0 productdimensions=defaultdimensions sql="select * from products where catalogid=" & catalogid set rs=dbc.execute(sql) if not rs.eof then weight=rs("weight") if isNull(weight) then weight=0 end if supplierid=rs("supplierid") If isnull(supplierid) then supplierid=0 end if If getupsconfig("xdimensionfield",false, dbc)<>"" then tempdimensions=rs(getupsconfig("xdimensionfield",false, dbc)) if not isnull(tempdimensions) then productdimensions=tempdimensions end if end if indivproductvalue="" If getupsconfig("xcheckIndividualProduct",false, dbc)="Yes" and getupsconfig("xcheckIndividualProductField",false, dbc)<>"" then '3/1/2006 getupsconfig was missing indivproductvalue=rs(getupsconfig("xcheckindividualproductfield",false,dbc)) if isnull(indivproductvalue) then indivproductvalue="" end if end if If Getconfig("xfeatureweight")="Yes" and prodfeatures<>"" then GetTotalfeatureweight dbc, catalogid, prodfeatures, featureweight end if featureweight=featureweight*prodquantity totalfeatureweight=totalfeatureweight+featureweight end if weight=cdbl(weight)*Prodquantity weight = weight + Totalfeatureweight closerecordset rs end sub ' Sub ConvertCountries(country) if country="UK" then country="GB" exit sub end if end sub ' Sub FormatMethods dim i, tempoption, price, tempdisplay, tempvalue dim errors(10),errorcount shippingcount=0 for i =0 to tempmethodscount-1 Price=Tempprices(i) tempoption=TempMethods(i) tempdisplay=tempmethods(i) tempvalue=tempmethods(i) if Price<>0 then Tempvalue= Tempvalue & " [" & formatnumber(Price,getconfig("xdecimalpoint")) & "]" ShippingMethods(shippingcount)=tempDisplay ShippingValues(shippingcount) = tempvalue shippingprices(shippingcount)=shopformatcurrency(price, getconfig("xdecimalpoint")) shippingcount=shippingcount+1 end if next If shippingcount=0 then If isarray(sitms) then parserecord sitms(1),errors,errorcount,"%" serror="UPS rates failed with the following message
" serror=serror & errors(errorcount-1) & "
" end if end if end sub '*********************************************************** ' if product has a supplier and supplier other1 field is not bull ' Use that as shipping address ' the other1 field must also be filled in with anything ' in the suppliers table '*********************************************************** Sub Getsupplierzip (supplierid, shipzip) if getupsconfig("xUseSupplierZip",false,dbc)="No" then exit sub if supplierid=0 then exit sub dim sql, rs, other1, supdbc sql="select * from suppliers where supplierid=" & supplierid If getconfig("xproductdb")<>"" then shopopendatabase supdbc set rs=supdbc.execute(sql) else set rs=dbc.execute(sql) end if set rs=dbc.execute(sql) if not rs.eof then if not isnull(getupsconfig("xsuppliershipfield",false,dbc)) then shipfromzip=rs("postcode") shipfromcity=rs("city") shipfromstate=rs("state") shipfromcountry=rs("country") end if end if closerecordset rs If getconfig("xproductdb")<>"" then shopclosedatabase supdbc end if end sub '*********************************************************************** ' zero weight can be an error or it can be OK ' If xzeroweighterror+"nO" it is not an error and we simply continue '********************************************************************* Sub HandleZeroWeight If getupsconfig("xZeroweightError",false,dbc)="No" then setsess "smprice",0 responseredirect "Shopcreateorder.asp" end if AddError getlang("LangZeroWeight") end sub Sub adderror (msg) serror = serror & msg & "
" end sub '**************************************************************************** ' If auto separate we take a large weight and automatically divide it '********************************************************************** Sub Autoseparatepackages (totalweight, shiptozip, shiptocountry, shipfromzip) dim count, remainweight, singleweight, autoweight, i individualquantity=1 autoweight=clng(getupsconfig("xautoseparateweight",false, dbc)) count=totalweight/autoweight count=clng(count)+1 remainweight=totalweight For i = 0 to count if remainweight=0 then exit sub If remainweight>autoweight then singleweight=autoweight remainweight=remainweight-autoweight else singleweight=remainweight remainweight=0 end if If getupsconfig("xtrace",false, dbc)="Yes" then Debugwrite "autoseparate weight=" & singleweight end if GetUPSRates singleweight, productdimensions next end sub '************************************************************************ ' shipping from and to defaults for a package '********************************************************************** Sub MakeShippingDefaults shipfromzip=defaultshipzip shipfromstate=defaultshipstate shipfromcity=defaultshipcity shipfromcountry=defaultshipcountry ' If productdimensions<>"" then shipdimensions=productdimensions else shipdimensions=defaultdimensions end if ' shiptocountry=Defaultdestcountry Shiptozip=DefaultDestZip shiptocity=defaultdestcity shiptostate=defaultdeststate shiptocountry=defaultdestcountry end sub %>