<%
Dim DeliveryShippingFlag, DeliveryBasePrice, DeliveryMatch
'
'******************************************************
' VP-ASP 6.50  August 31, 2004
' Used when delivery based shipping is specified
' add feature weight
'*****************************************************
Sub DeliveryShippingCalc
dim shippingprice, price, deliveryarray, deliverytype
Dim prodid, prodquantity, prodprice, prodfeatures
dim prodconn
if getconfig("xDeliveryShipping")<>"Yes" then exit sub
'
scartItem = GetSess("CartCount")
arrCart = GetSessA("CartArray")
calculationtype=ucase(getconfig("xShippingCalc"))  ' What type of calculation are we doing
if calculationtype<>"LOOKUP" Then
   Shopopendatabase dbc
end if   
If getconfig("xshippingfreeproducts")="Yes" then
    shopopendatabaseP prodconn
end if    
Deliverybaseprice=getsess("smprice")
If isnumeric(Deliverybaseprice) then
   Deliverybaseprice=csng(DeliveryBasePrice)
else
   DeliveryBasePrice=0
end if
'Debugwrite "Delivery Baseprice=" & Deliverybaseprice
shippingprice=0
DeliveryMatch=0
DeliveryShippingFlag=False
dim calculate
' go through all products
For i = 1 to scartItem
    price=0
    DeliveryArray=arrCart(cDelivery,i)
    prodid=arrCart(cProductid,i)
    Prodquantity=arrCart(cQuantity,i)
    ProdPrice=arrCart(cUnitPrice, i)
    Prodfeatures=arrCart(cProductfeatures, i)
    If isarray(deliveryarray) then 
        calculate=true
        Deliverytype=Deliveryarray(dDeliveryType)
        If Deliveryarray(dDeliveryType)<>getlang("LangDeliverySelf") then
           DeliveryMatch=DeliveryMatch+1
           if getconfig("xshippingfreeproducts")="Yes" then 
              Calculate=CheckDeliveryFree(prodconn, prodid)
            end if
          if calculate=True then    
           
           Select Case CalculationType
           Case "LOOKUP"
            DeliverybyLookup price, prodid, prodquantity, prodprice, deliveryarray
           Case "WEIGHT"
            DeliverybyWeight price, prodid, prodquantity, prodprice, deliveryarray, prodfeatures
           Case "QUANTITY"
             DeliverybyQuantity price, prodid, prodquantity, prodprice, deliveryarray
           Case "WEIGHTRANGE"
             DeliverybyWeightRange price, prodid, prodquantity, prodprice, deliveryarray, prodfeatures
           Case "PRICERANGE"
             DeliverybyPriceRange price, prodid, prodquantity, prodprice, deliveryarray
            Case "QUANTITYRANGE"
		DeliverybyQuantityrange price, prodid, prodquantity, prodprice, deliveryarray 
            end select
            shippingprice=shippingprice+price 
          end if  
         end if         
     end if    
next
If Deliverymatch<>scartitem then
   shippingprice=shippingprice+DeliveryBasePrice
end if   
SetSess "smprice",shippingprice
if calculationtype<>"LOOKUP" Then
   Shopclosedatabase dbc
end if
If getconfig("xshippingfreeproducts")="Yes" then
    shopclosedatabase prodconn
end if       
end sub
'
Sub DeliveryByQuantityRange(price, prodid, prodquantity, prodprice, deliveryarray)
'**************************************************************************
' adeecSEpt 21
'**************************************************************************  
Dim Totalquantity
Totalquantity=0
ShopOpenDatabase dbc              ' find
TotalQuantity=prodquantity      ' total quantity of product
If getconfig("XdeliveryAddress")="Yes" and Totalquantity=0 then exit sub
DeliveryLocateShippingQuantityRange shipmethod, TotalQuantity, price
end sub


Sub DeliveryLocateShippingQuantityRange (Shipmethod, TotalQuantity, price)
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 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 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  
		Price= Price + TotalPrice
      rsitems.close
      ShopCloseDatabase dbc
     'debugwrite "Total=" & totalprice & " AddPrice=" & addprice  
      exit sub 
   end if 
   rsitems.movenext   
loop
Price=99999.97
rsitems.close
ShopCloseDatabase dbc
end sub

'**************************************************************************
' Lookup already nows price but we may have a specific product 
' that has no shipping cost
'**************************************************************
Sub  DeliverybyLookup (price, prodid, prodquantity, prodprice, deliveryarray)
price=Deliverybaseprice
end sub

'***************************************************************************
' Calculate shipping cost by weight
'*****************************************************************************
Sub  DeliverybyWeight (price, prodid, prodquantity, prodprice, deliveryarray, prodfeatures)
Dim weight, totalprice, shipcost, rs, sql, featureweight
weight=0
sql="Select weight from products where catalogid=" & prodid
set rs=dbc.execute(sql)
if not rs.eof then
   weight=rs("weight")
   if not isnull(weight) then
      weight=weight*prodquantity
   end if
end if
rs.close
set rs=nothing
If Getconfig("Xfeatureweight")="Yes" and prodfeatures<>"" then 
    GetTotalfeatureweight dbc, prodid, prodfeatures, featureweight
end if
weight=weight+(featureweight*prodquantity)    
TotalPrice=0
If not isnull(curshipbaseCost) then
   TotalPrice=curShipBaseCost
end if
ShipCost=CurShipExtraCost
Price = Weight* prodquantity * ShipCost
Price= Price + TotalPrice

end sub

Sub  DeliverybyQuantity (price, prodid, prodquantity, prodprice, deliveryarray)
'**************************************************************************
' Use number of items as shipping calculation
' QuantityBase = base shipping Price
' QuantityExtra= Extra amount per item
'**************************************************************************  
Dim ShippingPrice
Dim TotalPrice
Dim QuantityExtra
TotalPrice=0           ' from database 
'debugwrite "shipmethod=" & shipmethod
QuantityExtra=curShipExtracost    ' extra per unit 
If isnull(QuantityExtra) then
    QuantityExtra=0
end if
TotalPrice=curShipBaseCost          ' base amount
ShippingPrice = prodquantity * QuantityExtra
Price= ShippingPrice + TotalPrice
end sub

Sub DeliveryByPriceRange (price, prodid, prodquantity, prodprice, deliveryarray)
'**************************************************************************
' 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=Prodprice*Prodquantity
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")
      rsitems.close
      set rsitems=nothing
      price=ShipCost
      exit sub 
   end if 
   rsitems.movenext   
loop
ShipCost=0
rsitems.close
set rsitems=nothing
end sub

'*************************************************************************
' get total weight of product plus any feature weight
' then look it up in range table
'***************************************************************************
Sub DeliveryByWeightRange( price, prodid, prodquantity, prodprice, deliveryarray, prodfeatures)
dim sql, rs
Dim weight
Dim TotalWeight
TotalWeight=0
Price=0 
sql="Select weight from products where catalogid=" & prodid
set rs=dbc.execute(sql)
if not rs.eof then
   totalweight=rs("weight")
   if not isnull(totalweight) then
      totalweight=totalweight*prodquantity
   end if
end if
rs.close
set rs=nothing
If Getconfig("Xfeatureweight")="Yes" and prodfeatures<>"" then 
    GetTotalfeatureweight dbc, prodid, prodfeatures, featureweight
end if
totalweight=totalweight+(featureweight*prodquantity)    
LocateDeliveryWeightRange price, shipmethod, TotalWeight
'Debugwrite "weightprice=" & price & "totalweight=" & totalweight
end sub

Sub LocateDeliveryWeightRange (Totalprice, Shipmethod, Totalweight)
dim rsitems
dim lowweight, highweight
Dim addprice
Dim Extraweight
Dim ExtraPrice
SetSess "ShipCalc","Weight Range"
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
  '    debugwrite "Total=" & totalprice & " AddPrice=" & addprice  
      exit sub 
   end if 
   rsitems.movenext   
loop
rsitems.close
set rsitems=nothing
end sub
%>