<%
Dim ShipMethod
Dim ShipCost
Dim ShippingMethods(50)
Dim ShippingCount
Dim CalculationType
dim upsdbc
const productcostfield="weight"   ' set to other field if necessary
'**********************************************************************
' Version 4.50 You can select  different types of shipping
' April 21, 2002
' in shop$config.asp
' Const xShippingCalc="Lookup"   fixed price lookup in database+delivery
' Const xShippingCalc="Weight"    Calculate by weight + delivery
' Const xShippingCalc="Quantity"  Calculate by Quantity
' Const xShippingCalc="WeightRange" 'lookup total weight+ delivery
' Const xShippingCalc="PriceRange"  ' lookup by price range +delivery
' Const xShippingCalc="Product"    ' shipping is unique to product(weight field has value) 
' Const xShippingCalc="Fixed" 
' const xshippingcalc="Other"      ' ' other requires shiproutine to be filled in 
' const xshippingcalc="QuantityRange"      ' ' other requires shiproutine to be filled in 
'*********************************************************************
'
Sub UpdateShippingSessionData()
' called from shop customer to process form and get shipping price
Dim optionname
Dim optionPrice
SetSess "shipname", strshipname
SetSess "shipcompany", strshipcompany
SetSess "shipaddress", strshipaddress
SetSess "shiptown", strshiptown
SetSess "shipzip", strshipzip
SetSess "shipstate", strshipstate
SetSess "shipcountry", strshipcountry
    ShipMethodType=Request.form("ShipMethodType")
    if shipmethodtype="" then
       shipmethodtype=getconfig("xfixedshippingmethod")
    end if   
    SetSess("Shipmethodtype"),Shipmethodtype
    ParseOption ShipMethodType, ShipMethod, ShipCost
    SetSess "ShipMethod",Shipmethod
    If getconfig("Xcurrencysymbol")<>"" and Shipcost<>"" then
       shipcost=replace(shipcost,getconfig("xcurrencysymbol"),"")
    end if   
    SetSess "smprice",ShipCost
    If ucase(getconfig("xshippingCalc"))="LOOKUP" then
         SetSess "ShipCalc","LOOKUP"
         DeliveryShippingCalc
         exit sub
    end if 
CalculateShipping    ' all others handled differently
if getconfig("xDeliveryShipping")="Yes" then 
  DeliveryShippingCalc    ' handle delivery shipping
end if  
end sub
'

Sub CalculateShipping

Calculationtype=ucase(getconfig("xShippingCalc"))  ' What type of calculation are we doing
If Calculationtype="" then exit sub
Select Case CalculationType
     Case "WEIGHT"
         HandlebyWeight
     Case "QUANTITY"
         HandlebyQuantity
     Case "WEIGHTRANGE"
         HandlebyWeightRange
     Case "PRICERANGE"
         HandlebyPriceRange
     Case "FIXED"
         HandlebyFixed
     Case "UPSTABLE"          ' not supported
         HandlebyUPS
     Case "PRODUCT"
         HandlebyProduct
     Case "QUANTITYRANGE"
         HandlebyQuantityrange
     Case "OTHER"
         HandlebyOther
     Case else
          Serror="Unknown Shipping Method"
end select          
end sub

Sub GetShippingDatabase
'***************************************************
' Read database and store dat in shippingmethods array
'*************************************************
Dim rsship
Dim dbc
Dim TempOption
Dim TempPrice
dim prevMethod
shippingcount=0
prevmethod=""
If ucase(getconfig("xShippingCalc"))="UPSTABLE"  then
     GetUPSShippingDatabase
     exit sub
end if 
ShopOpenDatabase dbc
Set rsship = Server.CreateObject ("ADODB.Recordset")
SQL="Select * from shipmethods order by shipmethod"
rsship.Open SQL, dbc, adOpenForwardOnly,adLockReadOnly, adCmdText
Do While Not rsship.EOF
    TempOption = rsship("shipmethod")
    TempPrice=rsship("smprice")
    If getconfig("xdisplayprices")="No" then
        TempPrice=""
    end if    
    if TempPrice<>"" then
        if TempPrice<>0 then
               TempOption= TempOption & " [" & formatnumber(TempPrice,getconfig("xdecimalpoint")) & "]"
         end if
   end if
   if TempOption<>PrevMethod then
      ShippingMethods(shippingcount)=TempOption
      PrevMethod=TempOption
      If ShippingCount=0 then
         If GetSess("Shipmethodtype")<>"" then
             shipmethodtype=Getsess("shipmethodtype")
         else    
            ShipMethodType=ShippingMethods(0) ' set defaut method
         end if   
       end if
       shippingcount=shippingcount+1
     end if
rsship.MoveNext 
Loop
closerecordset rsship
ShopCloseDatabase dbc
end sub

'*************************************************
Sub LocateShippingRecord (Shipmethod)
' gets one shipping method from database
dim shipsql
Dim i
' Reread database record for a particular method
ShopOpenDatabase dbc
ShipSql="Select * from shipmethods where Shipmethod='" & shipmethod & "'"
Set objRS = dbc.Execute(shipsql)
If objRS.EOF Then
     SEtSess "ShipError",shipsql
     Shipmethod = "Database Error"
     
Else
        lngshipmethodid = objrs("shipmethodid")
	strshipmethod = objrs("shipmethod")
	cursmprice = objrs("smprice")
        curshipbasecost = objrs("shipbasecost")
	curshipextracost = objrs("shipextracost")
        if isnull(curshipbasecost) then
           curshipbasecost=0
        end if
        if isnull(curshipextracost) then
           curshipextracost=0
        end if
	strshipother1 = objrs("shipother1")
	strshipother2 = objrs("shipother2")
	curshipcost2 = objrs("shipcost2")
	curshipcost1 = objrs("shipcost1")
        ShipCost=curSmprice
End If
closerecordset objrs
ShopcloseDatabase dbc
End Sub
'
Sub HandleByWeight
'**************************************************************************
' ShipMethod
' ShipCost 
'**************************************************************************  
dim prodid, prodcode, prodname, Prodquantity, ProdPrice
Dim weight
Dim i
Dim ShippingPrice
Dim TotalPrice
Dim rsitem
Dim ShippingCost
Dim calculate, deliveryarray
LocateShippingRecord Shipmethod
TotalPrice=0
If not isnull(curshipbaseCost) then
   TotalPrice=curShipBaseCost
end if
ShipCost=CurShipExtraCost
'debugwrite "shipping cost=" & Totalprice
'
ShopOpenDatabase dbc
scartItem = GetSess("CartCount")
arrCart = GetSessA("CartArray")
' go through all products
For i = 1 to scartItem
    calculate=true
    prodid=arrCart(cProductid,i)
    prodcode=arrCart(cProductCode,i)
    prodname= arrCart(cProductname,i)
    Prodquantity=arrCart(cQuantity,i)
    ProdPrice=arrCart(cUnitPrice, i)
    Deliveryarray=arrcart(cDelivery,i)
    Calculate=CheckDeliverySelf(deliveryArray)
    If calculate=True then 
       GetProductRecord dbc, rsitem, prodid
       If Not rsItem.EOF Then
          weight=rsitem("weight")
          if isNull(weight) then
            weight=0
          end if
          ShippingPrice = Weight* prodquantity * ShipCost
          TotalPrice= ShippingPrice + TotalPrice
          If getconfig("xdebug")="Yes" then 
           Debugwrite "ShippingPerItem=" & ShipCost & "weight=" & weight & " quantity=" & prodquantity
           Debugwrite "shippingPrice=" & ShippingPrice
          debugwrite "total=" & Totalprice 
          end if
       end if    
       rsitem.close
       set rsitem=nothing
     end if  
Next
ShopCloseDatabase  dbc
SetSess "smprice",TotalPrice
SetSess "ShipMethod",ShipMethod & " by weight"
SetSess "shipcalc","Weight"
end sub

Sub HandleByProduct
'**************************************************************************
' ShipMethod
' ShipCost 
' The weight field in the database actually has product shipping cost
'**************************************************************************  
Dim rssql
Dim i
Dim ShippingPrice
Dim TotalPrice
Dim rsitem
Dim ShippingCost
Dim Prodid, prodquantity
ShopOpenDatabase dbc
scartItem = GetSess("CartCount")
arrCart = GetSessA("CartArray")
' go through all products
For i = 1 to scartItem
    prodid=arrCart(cProductid,i)
    Prodquantity=arrCart(cQuantity,i)
    rssql="Select * from products where catalogid=" & prodid
    set rsitem=dbc.execute(rssql)
    If Not rsItem.EOF Then
        shippingcost=rsitem(ProductCostField)
        if isNull(shippingcost) then
            shippingcost=0
        end if
         ShippingPrice = shippingcost* prodquantity 
         TotalPrice= ShippingPrice + TotalPrice
         If getconfig("xdebug")="Yes" then 
           Debugwrite "ShippingPerItem=" & ShippingCost & " quantity=" & prodquantity
           Debugwrite "shippingPrice=" & ShippingPrice
          debugwrite "total=" & Totalprice 
        end if 
    end if
    rsitem.close
    set rsitem=nothing 
Next
ShopCloseDatabase  dbc
SetSess "smprice",TotalPrice
end sub
'
Sub HandleByQuantity
'**************************************************************************
' Use number of items as shipping calculation
' QuantityBase = base shipping Price
' QuantityExtra= Extra amount per item
'**************************************************************************  
dim prodid, prodcode, prodname, Prodquantity, ProdPrice
Dim i, calculate
Dim ShippingPrice
Dim TotalPrice
Dim QuantityExtra, DEliveryArray
TotalPrice=0           ' from database 
'debugwrite "shipmethod=" & shipmethod
LocateShippingRecord Shipmethod 
QuantityExtra=curShipExtracost    ' extra per unit 
If isnull(QuantityExtra) then
    QuantityExtra=0
end if
TotalPrice=curShipBaseCost          ' base amount
scartItem = GetSess("CartCount")
arrCart = GetSessA("CartArray")
' go through all products
For i = 1 to scartItem
    Calculate=True
    prodid=arrCart(cProductid,i)
    prodcode=arrCart(cProductCode,i)
    prodname= arrCart(cProductname,i)
    Prodquantity=arrCart(cQuantity,i)
    ProdPrice=arrCart(cUnitPrice, i)
    Deliveryarray=arrcart(cDelivery,i)
    Calculate=CheckDeliverySelf(deliveryArray)
    If calculate=True then 
      ShippingPrice = prodquantity * QuantityExtra
      TotalPrice= ShippingPrice + TotalPrice
    end if   
    If getconfig("xdebug")="Yes" then
      Debugwrite "ExtraPerItem=" & QuantityExtra & " quantity=" & prodquantity
      Debugwrite "shippingPrice=" & ShippingPrice
      debugwrite "total=" & Totalprice 
    end if
Next
SetSess "smprice",TotalPrice
SetSess "ShipMethod",ShipMethod & " by quantity"
SetSess "shipcalc","Quantity"
end sub

Sub HandleByPriceRange
'**************************************************************************
' Use numer of items as shipping calculation
' Calculate fill Price
'**************************************************************************  
Dim weight
Dim i
Dim ShippingPrice
Dim TotalPrice
Dim rsitem
Dim ShippingCost
dim rsitems
dim lowvalue, highvalue
dim shipsql
'
TotalPrice=GetSess("OrderProductTotal")
If getconfig("Xdeliveryshipping")="Yes"  then 
   CalculateTotalPrice totalprice
   If totalprice=0 then exit sub
end if   
ShopOpenDatabase dbc              ' find
' Find the weight range using shipother1 and shipother2
'debugwrite "searching for " & shipmethod & " for Price " & totalPrice
' Reread database record for a particular method
ShipSql="Select * from shipmethods where Shipmethod='" & shipmethod & "'"
Set rsitems=dbc.execute(shipsql) 
do while not rsitems.eof 
   lowvalue=rsitems("shipcost1")
   highvalue=rsitems("shipcost2") 
   'debugwrite "low=" & lowvalue & " high=" & highvalue
   if totalprice >= lowvalue and totalprice < highvalue then
      shipcost= rsitems("shipbasecost")
      closerecordset rsitems
      ShopCloseDatabase dbc
      SetSess "smprice",ShipCost
      exit sub 
   end if 
   rsitems.movenext   
loop
ShipCost=0
closerecordset rsitems
ShopCloseDatabase dbc
SetSess "smprice",ShipCost
SetSess "ShipCalc","Price Range"
end sub

Sub HandleByWeightRange
'**************************************************************************
' Use numer of items as shipping calculation
'  Calculate weight on product id
' If shipother1 set then use extra when weight exceeds
'  Shipother1=LowWeight Range
'  ShipOther2=highweightrange
'  ShipBasecost=cost in that range
'  Shipextracost  if weight exceeds low range
'  
'  shipmethod	smprice	ShipBaseCost	ShipExtraCost	ShipOther1   ShipOther2	
'  GROUND		$8.50	        $2.00	          0   		100	
'  2nd DAY AIR		$18.50	        $3.00	          2			
'  Next Day Air		$35.50	        $3.50	          2			
'  International	$49.50	        $9.00	          2			
'**************************************************************************  
Dim weight
Dim i
Dim ShippingPrice
Dim TotalPrice
Dim rsitem
Dim ShippingCost
Dim TotalWeight
TotalWeight=0
TotalPrice=0             ' set base price from database or a constant
ShopOpenDatabase dbc              ' find
GetProductWeight TotalWeight      ' total weight of product
If getconfig("XdeliveryAddress")="Yes" and Totalweight=0 then exit sub
LocateShippingWeightRange shipmethod, TotalWeight
end sub
'
' Get total weight of products
Sub GetProductWeight (totalWeight)
dim prodid, prodcode, prodname, Prodquantity, ProdPrice
dim rsitem, deliveryarray, deliverytype
dim i, calculate
dim weight
scartItem = GetSess("CartCount")
arrCart =   GetSessA("CartArray")
' go through all products
For i = 1 to scartItem
    Calculate=True
    prodid=arrCart(cProductid,i)
    prodcode=arrCart(cProductCode,i)
    prodname= arrCart(cProductname,i)
    Prodquantity=arrCart(cQuantity,i)
    ProdPrice=arrCart(cUnitPrice, i)
    DeliveryArray=arrCart(cDelivery, i)
    If getconfig("Xdeliveryshipping")="Yes"  and isarray(deliveryarray) then
       Deliverytype=Deliveryarray(dDeliveryType)
       If Deliveryarray(dDeliveryType)<>LangDeliverySelf then
          Calculate=False
       end if
    end  if
    If calculate=True then
      GetProductRecord dbc, rsitem, prodid
       If Not rsItem.EOF Then
        weight=rsitem("weight")
        if isNull(weight) then
            weight=0
        end if
 '      Debugwrite "name=" & prodname & " quantity " & prodquantity & " weight=" & weight
       weight=weight*ProdQuantity 
       TotalWeight=weight+totalweight
      end if 
      rsitem.close
      set rsitem=nothing
    end if  
Next
SetSess "Totalweight",Totalweight
'debugwrite "totalweight=" & totalweight
end sub

Sub LocateShippingWeightRange (Shipmethod, Totalweight)
dim rsitems
dim lowweight, highweight
Dim addprice
Dim Extraweight
Dim ExtraPrice
Dim TotalPrice
SetSess "ShipCalc","Weight Range"
' Find the weight range using shipother1 and shipother2
'debugwrite "searching for " & shipmethod & " for weight " & totalweight
SetSess "Shipmethod",Shipmethod
dim shipsql
' Reread database record for a particular method
ShipSql="Select * from shipmethods where Shipmethod='" & shipmethod & "'"
Set rsitems=dbc.execute(shipsql) 
do while not rsitems.eof 
   lowweight=rsitems("shipother1")
   highweight=rsitems("shipother2") 
  'debugwrite "low=" & lowweight & " high=" & highweight
   if not isnull(lowweight) then 
        lowweight=clng(lowweight)
   end if  
   if not isnull(highweight) then 
        highweight=clng(highweight)
   end if  
    if totalweight >= lowweight and Totalweight <= highweight then
      ShipCost= rsitems("ShipBaseCost")
   '   Debugwrite "basecost=" & Shipcost 
      Extraweight=totalweight-Lowweight
      extraprice=rsitems("shipextracost")
      AddPrice=0
      If not isnull(Extraprice) then  
        
        If Extraweight>0 then
          AddPrice=ExtraWeight*ExtraPrice
        end if
      end if
      TotalPrice=ShipCost+AddPrice  
      rsitems.close
      set rsitems=nothing
      ShopCloseDatabase dbc
      SetSess "smprice",TotalPrice
  '    debugwrite "Total=" & totalprice & " AddPrice=" & addprice  
      exit sub 
   end if 
   rsitems.movenext   
loop
ShipCost=99999.99
rsitems.close
set rsitems=nothing
ShopCloseDatabase dbc
SetSess "smprice",ShipCost
end sub

Sub HandleByFixed
' Need to add xshippingmethod and xshipping cost to shop$config for this to work
ShipMethod=getconfig("xFixedShippingMethod")
SetSess "smprice",getconfig("xFixedShippingCost")
SetSess "ShipMethod",getconfig("xShippingMethod")
end sub


Sub GetUPSShippingDatabase
'***************************************************
' Get the total Weight
' Select the different methods
' Use ShipOther1 as Index into UPS Rate table
'*************************************************
Dim rsship1
Dim TempOption
Dim TempPrice
dim prevMethod
Dim UpsMethod
shippingcount=0
Dim totalweight
prevmethod=""
ShopOpendatabase dbc
GetProductWeight Totalweight       ' get total weight
Set rsship1 = Server.CreateObject ("ADODB.Recordset")
SQL="Select * from shipmethods order by shipmethod"
rsship1.Open SQL, dbc, adOpenForwardOnly,adLockReadOnly, adCmdText
Do While Not rsship1.EOF
    tempoption = rsship1("shipmethod")
    upsmethod=rsship1("shipother1")
    LocateUPSRecordRange UpsMethod, TotalWeight, TempPrice
    if TempPrice<>"" then
         TempOption= TempOption & "   [" & shopformatcurrency(TempPrice,xdecimalpoint) & "]"
         ShippingMethods(shippingcount)=TempOption
         PrevMethod=TempOption
         shippingcount=shippingcount+1
    end if
rsship1.MoveNext 
Loop
closerecordset rsship1
Shopclosedatabase dbc
end sub

Sub HandleByUPS
'**************************************************************************
' Everything is already set for us , se we just parse it and use it
'**************************************************************************  
Dim Optionname, OptionPrice
ShipMethodType=Request.form("ShipMethodType")
ParseOption ShipMethodType, Optionname, OptionPrice
SetSess "ShipMethod",optionname
SetSess "Smprice",OptionPrice
end sub
'

Sub LocateUPSRecordRange (UpsMethod, Totalweight, Price)
dim rsitems
dim lowweight, highweight
' Find the weight range using shipother1 and shipother2
'debugwrite "searching for " & shipmethod & " for weight " & totalweight
dim shipsql
Price=""
' Reread database record for a particular method
ShipSql="Select * from UPSRates "
Set rsitems=dbc.execute(shipsql) 
do while not rsitems.eof 
   Lowweight=rsitems("lowweight")
   Highweight=rsitems("highweight") 
  'debugwrite "low=" & lowweight & " high=" & highweight
   if not isnull(lowweight) then 
        lowweight=clng(lowweight)
   end if  
   if not isnull(highweight) then 
        highweight=clng(highweight)
   end if  
    if totalweight >= lowweight and Totalweight <= highweight then
      Price= rsitems(UpsMethod)
      closerecordset rsitems
      If Isnull(Price) then
         Price=""
      end if
 '     Debugwrite "weight=" & totalweight & "price=" & Price
      exit sub 
   end if 
   rsitems.movenext   
loop
closerecordset rsitems
Price=""
end sub

Sub HandlebyOther
'*******************************************************************
' This allows a totally extendable shipping system by allowing the
' routine to be specified in the database
'******************************************************************
dim ShipSql, shipmethod, shiprs, routine
shipmethod=Getsess("shipmethod")
shipsql="Select * from shipmethods where shipmethod='" & shipmethod & "'"
ShopOpendatabase dbc
set shiprs=dbc.execute(shipsql)
routine=shiprs("shiproutine")
if not isnull(routine) then
    Setsess "followonURL",routine
end if
' no routine name treat as lookup
shiprs.close
set shiprs=nothing
ShopCloseDatabase dbc
end sub

Sub CalculateTotalPrice( TotalPrice)
dim Prodquantity, ProdPrice, deliveryarray, i, price
Dim scartiten, arrcart
scartItem = GetSess("CartCount")
arrCart =   GetSessA("CartArray")
dim Calculate
' go through all products
totalprice=0
For i = 1 to scartItem
    calculate=True
    Prodquantity=arrCart(cQuantity,i)
    ProdPrice=arrCart(cUnitPrice, i)
    DeliveryArray=arrCart(cDelivery,i)
    Calculate=CheckDeliverySelf(deliveryArray)
    If Calculate=True then
       Price=ProdPrice*ProdQuantity
       totalprice=totalprice+price
    end if 
Next
'debugwrite "totalPrice=" & totalPrice
end sub

Function CheckDeliverySelf (deliveryArray)
' Returns tru if to calculate this product
Dim DeliveryType
CheckDeliverySelf=True
If getconfig("Xdeliveryshipping")<>"Yes" then exit function
If isarray(deliveryarray) then
   Deliverytype=Deliveryarray(dDeliveryType)
   If Deliveryarray(dDeliveryType)<>LangDeliverySelf then
      CheckDeliverySelf=False
   end if
end  if
end function

Sub HandleByQuantityRange
'**************************************************************************
' Quantity range calculation
'************************************************************************  
Dim Totalquantity
Totalquantity=0
ShopOpenDatabase dbc              ' find
GetProductQuantity TotalQuantity      ' total weight of product
'debugwrite "totalquantity=" & totalquantity
If Totalquantity=0 then exit sub
LocateShippingQuantityRange shipmethod, TotalQuantity
end sub

Sub GetProductQuantity( TotalQuantity )
dim scartitem, arrcart,i, prodquantity, deliveryarray, calculate
dim prodprice,Deliverytype
totalquantity=0
scartItem = GetSess("CartCount")
arrCart =   GetSessA("CartArray")
' go through all products
For i = 1 to scartItem
    Calculate=True
    Prodquantity=arrCart(cQuantity,i)
    ProdPrice=arrCart(cUnitPrice, i)
    DeliveryArray=arrCart(cDelivery, i)
    If getconfig("Xdeliveryshipping")="Yes"  and isarray(deliveryarray) then
       Deliverytype=Deliveryarray(dDeliveryType)
       If Deliveryarray(dDeliveryType)<>LangDeliverySelf then
          Calculate=False
       end if
    end  if
    If calculate=True then
      totalquantity=totalquantity+prodquantity
    end if 
Next
end sub 

Sub LocateShippingQuantityRange (Shipmethod, TotalQuantity)
dim rsitems
dim lowweight, highweight
Dim addprice
Dim Extraweight
Dim ExtraPrice
Dim TotalPrice
SetSess "ShipCalc","Quantity Range"
' Find the quantity range using shipother1 and shipother2
'debugwrite "searching for " & shipmethod & " for quantity " & totalquantity
SetSess "Shipmethod",Shipmethod
dim shipsql
' Reread database record for a particular method
shipsql="select * from shipmethods where shipmethod='" & shipmethod & "'"
Set rsitems=dbc.execute(shipsql) 
do while not rsitems.eof 
   lowweight=rsitems("shipother1")
   highweight=rsitems("shipother2") 
 '  debugwrite "low=" & lowweight & " high=" & highweight
   if not isnull(lowweight) then 
        lowweight=clng(lowweight)
   end if  
   if not isnull(highweight) then 
        highweight=clng(highweight)
   end if  
    if totalquantity >= lowweight and Totalquantity <= highweight then
      shipcost= rsitems("shipbasecost")
   '   Debugwrite "basecost=" & Shipcost 
      Extraweight=totalquantity-Lowweight
      extraprice=rsitems("shipextracost")
      AddPrice=0
      If not isnull(Extraprice) then  
        If Extraweight>0 then
          AddPrice=ExtraWeight*ExtraPrice
        end if
      end if
      TotalPrice=ShipCost+AddPrice  
      closerecordset rsitems
      ShopCloseDatabase dbc
      SetSess "smprice",TotalPrice
  '    debugwrite "Total=" & totalprice & " AddPrice=" & addprice  
      exit sub 
   end if 
   rsitems.movenext   
loop
ShipCost=99999.99
closerecordset rsitems
ShopCloseDatabase dbc
SetSess "smprice",ShipCost
end sub
'
Sub GetProductRecord (dbc, rsitem, prodid)
dim shipsql
ShipSql="Select * from products where catalogid=" & prodid
Set rsitem = dbc.Execute(shipsql)
end sub

%>