<%Response.buffer=TRUE%>
<!-- #include file="shop$config.asp" -->
<!-- #include file="shopinitapplication.asp" -->
<!-- #include file="shop$colors.asp" -->
<!-- #include file="shopvbs.asp" -->
<!-- #include file="shopsess.asp" -->
<!-- #include file="shopdelivery.asp" -->
<!-- #include file="shopproductsubs.asp" -->
<!-- #include file="shoplanguagesubs.asp" -->
<!-- #include file="shopsubs.asp" -->
<!-- #include file="shopmysqlsubs.asp" -->
<!-- #include file="shopheaders.asp" -->
<%
const xAccessOLE="Yes"        ' Yes uses Jet Ole 4.0 for Access
'*******************************************************************
' Almost all common routines are here and in shopdbsubs.asp
' This routine is included in all other shop routines
' VP-ASP 5.0
' June 17, time difference date fix and format number fix
' July 27, 2003 cusdtomer updates add check for quote
' July 30, 2003 Support ODBC 3.51 MYSQL
' Nov 19, 2003 Sun ASP 4.0 fix
'******************************************************
' Shopping cart attributes
'******************************************************
const cMaxCartAttributes=22
Const cProductid = 1
Const cProductCode = 2
Const cProductname = 3
Const cQuantity = 4
Const cUnitPrice = 5
Const cDualPrice = 6
Const cOriginalPrice=7
Const cCategory=8
Const cDiscount=9
Const cMinimumQuantity=10
const cSupplierid=11
Const cDelivery=12
const CStockLevel=13
const Cotherinfo=14
const cGroupDiscount=15
const cProductFeatures=16
const cMaximumQuantity=17
const cProductimage=18
const cProductweight=19
const cProductassociated=20
const cProductMiniName=21
'*****************************************************
' Common variables VP-ASP 5.00 
'*****************************************************
dim database
Dim dbname       
Dim SError
Dim con
Dim rsorder
'for record paging
Dim mypagesize
Dim maxpages
'Products
Dim lngCatalogid
Dim strCcode
Dim strCname
Dim memCdescription
Dim curCprice
Dim strCimageurl      
Dim datCdateavailable
Dim lngCstock
Dim lngCcategory
Dim strCategory
Dim strMfg
Dim strDescURL         ' link to extended description page
Dim strWeight
Dim strFeatures        ' Product Features 2.11
Dim strButtonImage
Dim StrcDescURL
Dim strPOther1
Dim strPOther2
Dim strpOther3
Dim lngpSubcatID    ' Version 2.3
Dim strSpecialoffer ' 2.4
Dim strRetailPrice  '2.4
Dim strAllowusertext  ' 2.45
Dim MemUserText
Dim strPother4    
Dim strPother5    
Dim strTemplate     '2.50
Dim memExDesc  
Dim strExtendedimage '2.50  
Dim strProductUserid       ' 2.50 
dim strSelectList   ' 2.50
Dim strkeywords    ' 2.50
Dim lngDiscount    ' calculated 3.0
Dim NewCustomerPrice ' calculated 3.0
Dim curOriginalPrice
dim strlevel3, strlevel4, strlevel5 ' 3.0
dim ProductFieldValid
Dim strGiftCertificate
dim strMinimumquantity
dim strsupplierid   ' 3.50
dim strcrossSelling
dim boolhide
dim strgroupfordiscount
dim strclanguage
dim strattachment, strdownload
dim strcustomermatch, strproductmatch, strcustomertype   
dim strpoints,strpointstobuy, strprice2,strprice3   ' 4.50
dim strmaximumquantity   '5.0
dim strfrontpage         ' 5.0
' Customer Data
Dim strCustomerId
Dim strFirstname
Dim strLastname
Dim strAddress
Dim strCity
Dim strState
Dim strPostcode
Dim strCountry
Dim strCompany
Dim strPhone
Dim strWorkphone
Dim strMobilephone
Dim strFax
Dim strEmail
Dim strWebsite
Dim lngContacttypeid
Dim strComments
Dim strContactreason
Dim lngLoginCount
Dim StrDiscount
dim strcustuserid
dim strcdualprice    ' dual price from product record

Dim strshipname
Dim strShipAddress
Dim strShipTown
Dim strShipZip
Dim strShipState
Dim StrShipCountry
Dim StrshipCompany
Dim strShipMethodType
Dim strShipCost
Dim strShipComment
Dim blnMailList
dim blncookieQuestion
dim strvatnumber ' 4.5
dim strhearaboutus ' 5.0

' Shipping table
Dim lngShipmethodid
Dim strShipmethod        ' shipping method
Dim curSmprice           ' price 
Dim curShipbasecost      ' base cost
Dim curShipextracost     ' extra per item 
Dim strShipother1        ' unused
Dim strShipother2        ' unused
Dim curShipcost2         ' unused
Dim curShipcost1         ' unused

' Database Access
Dim SQL
Dim objRS
Dim rsprod
dim mypage
dim maxrecs
Dim DESCRIPTION 
Dim CATEGORY
Dim CAT_ID
Dim SUBCAT
Dim Recno
Dim maxrec
Dim databasecnt
'features
Dim lngFeaturenum
Dim strFeaturecaption
Dim strFeaturename
Dim curFeatureprice
Dim strFeatureother
Dim strFeatureType
Dim StrFeatureMulti
Dim strFeatureRequired
dim strfeatureother1
dim strfeatureweight   '5.0
dim strfeatureimage    '5.0
dim strfeaturepercent  '5.0

Dim ProductOptions(100)
Dim FeatureRS
' SubCategories
Dim lngSubcategoryid
Dim strSubcategory
Dim strSubcatOther
Dim lngCategoryid
Dim Errors

'*******************************************************
' main database open for: access, Sql Server, ODBC and MYSQL
'*********************************************************
Sub ShopOpenDataBase (connection)
'Sess ("db")= needs to be set to access file name or ODBC connection
dim databasetype
databasetype=ucase(xdatabasetype)
ShopInit
if Getconfig("xLCID")<>"" then
   Session.LCID=getconfig("xlcid")             ' set user supplied LCID
end if
CheckValidOrdernumber
CheckValidLogin
If databasetype="" or databasetype="DRIVE" then
  ProcessAccessOpen connection
  exit sub
end if
if databasetype="ODBC" then
    database= GetSess("db")
    ProcessODBC connection
    exit sub
end if
if databasetype="SQLSERVER" then
   ProcessSQLServer connection
   exit sub
end if 
if databasetype="MYSQL" then
   ProcessMYSQLServer connection
   exit sub
end if 
if databasetype="MYSQL351" then
   ProcessMYSQLServer connection
   exit sub
end if 

end sub
'******************************************************
' Open Access Database
Sub ProcessAccessOpen(connection)
dim dblocation
dim strconn
dim database
database=GetSess("db") & ".mdb"          ' database name
dblocation=GetSess("dblocation")' location 
If dblocation<>"" then
     database = GetSess("dblocation") & "\" & database
end if
if ucase(xdatabasetype)="DRIVE" Then 
  If xAccessOle<>"Yes" then 
    strconn = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & database
  else
   strconn = "provider=microsoft.jet.oledb.4.0;persist security info=false;data source=" & database
  end if    
  'strconn = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=D:\webs\vpasp\data\shopping2.mdb"
else
 If xAccessole<>"Yes" then   
  strconn = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & Server.MapPath(database)
 else
   strconn = "provider=microsoft.jet.oledb.4.0;persist security info=false;data source="  & Server.MapPath(database)
 end if  
end if  
if getconfig("xdebug")="Yes" then 
  debugwrite strconn
end if  
Set connection = Server.CreateObject("ADODB.Connection")
on error resume next
If xsqlpwd="" then 
  connection.open strConn
else
    connection.open strConn,xsqluser,xsqlpwd
end if    
'SetSess "dbc", connection
If connection.errors.count> 0 then
   SetSess "Openerror", "Open Messages<br>" & connection.errors(0).description & " <br>" & GetSess("dbc")
else
   SetSess "Openerror",""
end if
End Sub
'******************************************************************************
Sub ProcessODBC (connection)
on error resume next
dim strconn
Set connection = Server.CreateObject("ADODB.Connection")
strconn=GetSess("db")              ' xdatabase = ODBC connection 
connection.open strConn
'SetSess "dbc", connection
If connection.errors.count> 0 then
   SetSess "Openerror", "Open Messages<br>" & connection.errors(0).description & " <br>" & GetSess("dbc")
else
   SetSess "Openerror", ""
end if
end sub
'******************************************************
' Open SQL Server
Sub ProcessSqlServer(connection)
Set connection = Server.CreateObject("ADODB.Connection")
Dim varServerIP, varUserName, varPassword, varDataBaseName
varServerIP = xSQLServer
varUserName = xSQLUser
varPassword = xSQLPwd
varDataBaseName = GetSess("db")
Connection.Open "DRIVER={SQL Server}; Server=" & varServerIP & "; Database=" & varDataBaseName & "; UID=" & varUserName & "; PWD=" & varPassword'
If connection.errors.count> 0 then
   SetSess "Openerror","Open Messages<br>" & connection.errors(0).description & " <br>" & GetSess("dbc")
else
   SetSess "Openerror", ""
end if
end sub
'
'******************************************************
' Open MYSQL 
Sub ProcessMYSqlServer(connection)
Set connection = Server.CreateObject("ADODB.Connection")
Dim varServerIP, varUserName, varPassword, varDataBaseName
varServerIP = xSQLServer
varUserName = xSQLUser
varPassword = xSQLPwd
varDataBaseName = GetSess("db")
dim mysqlconn
on error resume next
'debugwrite "DRIVER={MySQL}; Server=" & varServerIP & "; Database=" & varDataBaseName & "; UID=" & varUserName & "; PWD=" & varPassword'
if ucase(xdatabasetype)="MYSQL351" then
     mysqlconn="DRIVER={MYSQL ODBC 3.51 Driver};"
else
     mysqlconn="DRIVER={MySQL}; "
end if
mysqlconn=mysqlconn &  " Server=" & varServerIP & "; Database=" & varDataBaseName & "; UID=" & varUserName & "; PWD=" & varPassword        
Connection.Open mysqlconn
'Connection.Open "DRIVER={MySQL}; Server=" & varServerIP & "; Database=" & varDataBaseName & "; UID=" & varUserName & "; PWD=" & varPassword'
If connection.errors.count> 0 then
   SetSess "Openerror","Open Messages<br>" & connection.errors(0).description & " <br>" & GetSess("dbc")
else
   SetSess "Openerror", ""
end if
'SetSess "dbc", connection
end sub

'***************
Sub ShopCloseDatabase (connection)
on error resume next
connection.close
set connection=nothing
End sub
' By change the shoppage_header and trailer you can make shop look specific to your merchant
'*******************************
Sub ShopCancelOrder
' called on cancel or when finished with order
SetSess "CartCount",0
SetSess "oid",""
SetSess "orderid",""
SetSess "smprice", ""
SetSess "taxes", ""
'If GetSess("Login")= "" then
'   SetSess "Lastname",""
'end if
SetSess "Giftid",""
SetSess "GiftCertificate",""
SetSess "Giftcount",""
SetSess "GiftAmountMax",""
SetSess "GiftAmountUsed",""
SetSess "CouponDiscount",""
SetSess "Coupon",""
setsess "shipmessage",""
End Sub

'********************************************************************************
' all routines dealing with actual cart are here
'  CartaddItem ()
'  CartInit
'********************************************************************************
'****** CartInit
Sub CartInit
  Dim ArrCart
  dim maxcartitems, cartattributes
  maxcartitems=getconfig("xmaxcartitems")
  cartattributes=cMaxCartattributes
  If maxcartitems="" then exit sub
  ReDim arrcart(cartAttributes,maxCartItems)
  SetSessA "CartArray", arrcart
  SetSess  "CartCount",  0
End Sub

' ******** Get Product from database
Sub CartGetProduct(id, rc)
' change to SQl Query from Filter
If id=lngcatalogid then
   if productfieldvalid=true then
       exit sub
   end if
end if       
dim dbc
dim productql
dim rsitem
ShopOpenDataBase dbc
if dbc="" then
    Response.write "Unable to open database <br>" & GetSess("dbc")
    rc=4
    exit sub
end if
productql="select * from products where catalogid=" & id
Set rsItem = dbc.execute(Productql)
If Not rsItem.EOF Then
   ProductGetValues rsitem
   GetNameInCart rsitem          ' in shop$colors
   rc=0
else
   rc=4
end if
rsitem.close
set rsitem=nothing
ShopCloseDatabase  dbc
end sub

'******************************************************************************
' Logic to determine if we should reinitialize everyrthing
Sub ShopInit()
dim initname
initname="Init" & "_" & xshopid
if GetSess("INIT") <> "INIT" or GetSess("db")<>xdatabase then
    'debugwrite "setting up session db= " & GetSess("db")
    SetupSession
    ShopInitapplication
    CartInit
    setsess "language",getconfig("xlanguage")
    If application(initname)="Yes" then
        SetSess "INIT","INIT"       
    end if      
end if
end sub
Sub SetupSession()
' sets database for this session use "mydatabase" not "mydatabase.mdb"
' location is relative path to database such as ..\..\data
' end=1 means to reset everything regardless of current state
'
SetSess "db", ""
SetSess "dblocation",  xdblocation
SetSess "Shopadmin", ""
SetSess "ShopadminDB", ""
SetSess "GiftID", ""
If GetSess("Login")<>"Force" then
  SetSess "Login",""
end if
database= GetSess("db")
if database="" then
  SetSess "db", xdatabase ' default value
end if
'response.write "Session initialized database = " & GetSess("db") & "<br>"
SetSessionTimeout
If getconfig("XCookieLogin")="Yes" then
   RestoreCustomerDetailsCookie
end if   
end sub
'
Sub GetDB()
'used to set database name from form or querystring
' sets database for this session from quertstring or form
dim database
database=Request("db")
if database <> "" then
    SetSess "db",database 
    exit sub
end if 
'responseredirect "shoperror.asp?msg="& Server.URLEncode("Unable to locate database name") 
end sub
' SHopOpenRecordSet
Sub ShopOpenRecordSet (mysql, rstemp, mypagesize, mypage)
if dbc="" then
   exit sub
end if
If mysql="" Then
   shoperror getlang("LangRestart")
end if   
Set rstemp = Server.CreateObject("ADODB.RecordSet")
rstemp.cursorlocation=aduseclient
If getconfig("xmysql")<>"Yes" then
  rstemp.cachesize=5
end if  
if getconfig("xdebug")="Yes" then
  DebugWrite mysql
end if
rstemp.Open MYSQL,dbc,adOpenKeyset,adLockReadOnly, adCmdText
if not rstemp.eof then
   rstemp.movefirst
   rstemp.pagesize=mypagesize
   maxpages=cint(rstemp.pagecount)
   maxrecs=cint(rstemp.pagesize)
   rstemp.absolutepage=mypage
end if
end sub
'
Sub ParseOption (Productoption, OptionName, OptionPrice)
' Option is in Form option [$xx.yy]
Dim spos, epos
Dim namelength
Dim length
OptionPrice=0
Optionname=Productoption
const bracket= "["
const bracketend= "]"
spos = instr(1,Productoption, bracket)
if spos=0 then
        exit sub
end if
Namelength=spos-1
If namelength> 0 then
  Optionname= mid(ProductOption,1,namelength)
end if
spos=spos+1
epos = instr(spos,ProductOption,bracketend)
if epos=0 then
     exit sub
end if
Length=epos-spos
OptionPrice=Mid(ProductOption,spos,length)
'Response.write OptionPrice
end sub

Sub GenerateRadio (Fieldname,fieldvalue,radiotype, currentvalue)
if currentvalue=Fieldvalue then
%>
  <input type="radio" name="<%=RadioType%>" value="<%=fieldvalue%>" CHECKED><%=fieldname%><br>
<%
else
%>
  <input type="radio" name="<%=RadioType%>" value="<%=fieldvalue%>"><%=fieldname%><br>
<%
end if
end sub
Sub GenerateSelectV (iFieldnames,ifieldvalues,currentvalue,selectname,count, firstfield)
dim i
' Generates Select with values
%>
<select size=1 class='txtfielddropdown' name="<%=selectname%>">
<%
If firstfield<>"" then
   response.write "<option>" & firstfield & "</option>"
end if
for i = 0 to count-1
   If currentvalue= ifieldvalues(i) then
      response.write "<option value=" & ifieldvalues(i) & " selected>" &  iFieldnames(i) & "</option>" & vbcrlf
   else
      response.write "<option value=" & ifieldvalues(i) & ">" &  ifieldnames(i) & "</option>" & vbcrlf
   end if
next
%>
</select>
<%
end sub

Sub GenerateSelectNV (iFieldnames,currentvalue,selectname, count,firstfield)
' Generates select with no values
dim i
%>
<select size=1 class='txtfielddropdown' name="<%=selectname%>">
<%

If firstfield<>"" then
   response.write "<option>" & firstfield & "</option>"
end if
for i = 0 to count-1
   If currentvalue= ifieldnames(i) then
      response.write "<option Selected>" & ifieldnames(i) & "</option>"
   else
      response.write "<option>" & ifieldnames(i) & "</option>"
   end if
next
%>
</select>
<%
end sub

Sub GenerateSelectMULT (iFieldnames,fieldcount,currentvalues,currentvaluecount, selectname,firstfield)
' Generates select with no values
%>
<select MULTIPLE size=5  class='txtfielddropdown' name="<%=selectname%>">
<%
Dim Currentvalue
Dim j, i
Dim found
Currentvalue=""
If firstfield<>"" then
   response.write "<option>" & firstfield & "</option>"
end if
'response.write "Currentvalue=" & currentvalue & " " & selectname & "<br>"
for i = 0 to fieldcount-1
   If currentvaluecount> 0 then
        Found="FALSE"
        j=0
        Do WHILE found="FALSE" and j < currentvaluecount
            if iFieldnames(i)= Currentvalues(j) then
                currentvalue=ifieldnames(i)
                found="TRUE"
            end if
            j=j+1 
        Loop
   end if
   If currentvalue= ifieldnames(i) then
      response.write "<option Selected>" & ifieldnames(i) & "</option>"
   else
      response.write "<option>" & ifieldnames(i) & "</option>"
   end if
next
%>
</select>
<%
end sub
Sub DebugWrite (msg)
response.write msg & "<br>"
end sub
'
Sub DiagnosticOpen (connection,database,databasetype)
SetSess "db",database
databasetype=ucase(databasetype)
If databasetype="" then
  ProcessAccessOpen connection
  exit sub
end if
if databasetype="ODBC" then
    database= GetSess("db")
    ProcessODBC connection
    exit sub
end if
if databasetype="SQLSERVER" then
   ProcessSQLServer connection
   exit sub
end if 
if databasetype="MYSQL" then
   ProcessMYSQLServer connection
   exit sub
end if 
ProcessAccessOpen connection
end sub

' all admin now must use standard open
Sub OpenDB (ByRef con, d)
ShopOpenDatabase con
End Sub
%>
<%
'--------
Function GetAccess(user, con)
	sql = "select * from tbluser where fldusername = '" & user & "'"
	Set objRec = con.Execute(SQL)
	if not objrec.eof then
	   getaccess = objrec("fldaccess")
	else
	   getaccess=""
	end if       
	objRec.Close
	set objrec=nothing
End Function

'-------
Sub ShopCheckAdmin (filename)
If GetSess("ShopAdmin")="" Then
  If getconfig("XshowAdmin")<>"Yes" then
      shoperror getlang("LangAdminUnauth") 
  else
     responseredirect getconfig("xadminpage")
  end if
end if
If Getsess("ShopAdmindb")<>xdatabase then
  If getconfig("XshowAdmin")<>"Yes" then
      shoperror  getlang("LangAdminUnauth") 
  else
     responseredirect getconfig("xadminpage")
  end if
end if
If getconfig("xadminmenucheck")="Yes" then
   Validateadminmenu filename
end if
End Sub

Sub ValidateadminMenu(filename)
dim userid, scriptname, sql, rs, conn, id, menus
dim found, tempname, pos
userid=getsess("shopadmin")
Menus=Getsess("AdminMenus")
If menus="" then exit sub
if filename="" then exit sub
shopopendatabase conn
sql="select * from tblaccess where fldauto in (" & menus & ")"
'debugwrite sql
found=false
set rs=conn.execute(sql)
do while not rs.eof 
   tempname=rs("fldurl")
   pos=instr(tempname,filename)
   if pos>0 then 
      found=true
      exit do
   end if
   rs.movenext
loop      
rs.close
set rs=nothing
If found=true then exit sub
If getconfig("XshowAdmin")<>"Yes" then
     shoperror getlang("LangAdminUnauth") 
else
     responseredirect "shopadmin1.asp"
end if
end sub

'--- login user activity
Sub LogUser(user,io, dbc)
dim indate, intime
indate=datenormalize(date())
intime=time()
SetSess "ShopAdmindb",xdatabase
'Log Users IP Address, fldip was added into the table and sql
useripaddy=request.servervariables("REMOTE_ADDR")
on error resume next
	login = "insert into tbllog (fldusername,fldtime,flddate,fldinout,fldipaddress) values('" & user & _
	"','" & inTime & "','" & inDate & "','" & io & "','" & useripaddy & "')"
	dbc.Execute(login)
End Sub


'--- Build Access control table for user
Sub BuildAccess(id)
Dim objrec3, objrec2, ba, temp
Dim accessarray(100), accesslist, accesscount, accessfound, accessid,i
ba = "select * from tbluser where fldauto = " & id
Set objRec2 = con.Execute(ba)
If Objrec2.eof then
   Accesscount=0
else   
  AccessList=objrec2("fldaccess")
  If isnull(AccessList) then
   accesscount=0
  else
   parserecord accesslist,accessarray, accesscount,","
   for i = 0 to accesscount-1
      accessarray(i)=clng(accessarray(i))
   next   
  end if
end if  
objrec2.close
set objrec2=nothing
temp = "select * from tblaccess order by fldauto"
Set objRec3 = con.Execute(temp)
While Not objRec3.EOF
      accessfound=false
      accessid=objrec3("fldauto")
      for i=0 to accesscount-1
         if accessid=accessarray(i) then
            accessfound=True
            exit for
         end if
      next
      If accessfound=True then         
     	response.write "<input type=Checkbox name=Access value=" & objRec3("fldAuto") & " checked>" & objRec3("fldName") & "<br>"
      Else
	response.write "<input type=Checkbox name=Access value=" & objRec3("fldAuto") & ">" & objRec3("fldName") & "<br>"
      End If
      objRec3.MoveNext
Wend
objrec3.close
set objrec3=nothing
End Sub
Sub GetDataBaseTables (tables, tablecount,con)
'set array tables with names of tables in database
dim table
dim i
dim tblName
redim tables(250)
Set table = con.OpenSchema (20)
i=0
While Not table.EOF
  tblName= table("Table_Name")
    If Left(tblName,4) <> "MSys" AND Left(tblName,3) <> "sys" AND Left(tblName,4) <> "RTbl" Then
	  Tables(i)=tblName
          i=i+1
     end if
     table.MoveNext
Wend

Dim othertables(50),othercount,j
If getconfig("xothertables")<>"" then
   parserecord getconfig("xothertables"),othertables,othercount,","
   for j=0 to othercount-1
        tables(i)=Othertables(j)
        i=i+1
   next
end if        
tablecount=i
end sub
'****************************************************
'Open databases other than standard
Sub OpenOtherDatabase (connection, indb, inlocation, intype)
if getconfig("xLCID")<>"" then
   Session.LCID=getconfig("xLCID")             ' set user supplied LCID
end if
dim databasetype
SaveSessionDB
SetSess "db",indb
SetSess "Dblocation",inlocation
databasetype=ucase(intype)
If databasetype="" or databasetype="DRIVE" then
  ProcessAccessOpen connection
  RestoreSessionDB
  exit sub
end if
if databasetype="ODBC" then
    database= GetSess("db")
    ProcessODBC connection
    RestoreSessionDB
    exit sub
end if
if databasetype="SQLSERVER" then
   ProcessSQLServer connection
   RestoreSessionDB
   exit sub
end if 
if databasetype="MYSQL" or databasetype="MYSQL351" then
   ProcessMYSQLServer connection
   RestoreSessionDB
   exit sub
end if 
end sub

Sub SaveSessionDb
SetSess "Olddb",GetSess("db")
SetSess "Olddblocation", GetSess("dblocation")
end sub
Sub RestoreSessionDB
SetSess "db",GetSess("Olddb")
SetSess "dblocation",GetSess("Olddblocation")
end sub
'
Sub OpenOrderDB (connection)
dim dbtype
dim OtherDB
Dim dblocation
If getconfig("xorderdb")="" then
     ShopOpenDatabase connection
else
   Otherdb=getconfig("xorderdb")
   Dblocation=GetSess("dblocation")
   dbtype=xdatabasetype
   OpenOtherDatabase connection,OtherDB,dblocation, dbtype
end if
end sub
'
Sub OpenCustomerDB (connection)
dim dbtype
dim OtherDB
Dim dblocation
If getconfig("xCustomerdb")="" then
     ShopOpenDatabase connection
else
   Otherdb=Getconfig("xCustomerDB")
   Dblocation=xdblocation
   dbtype=xdatabasetype
   OpenOtherDatabase connection,OtherDB,dblocation, dbtype
end if
end sub
'
Sub OpenAffiliateDB (connection)
dim dbtype
dim OtherDB
Dim dblocation
If getconfig("xaffiliateDB")="" then
     ShopOpenDatabase connection
else
   Otherdb=getconfig("xaffiliateDB")
   Dblocation=xdblocation
   dbtype=xdatabasetype
   OpenOtherDatabase connection,OtherDB,dblocation, dbtype
end if
end sub
Sub EditOpenDatabase (connection, database, table)
dim mytable, newdatabase
mytable=ucase(table)
if MyTable="CUSTOMERS" then
    ShopOpenOtherDB connection, getconfig("XCustomerdb")
    exit sub
end if
if MyTable="ORDERS" or Mytable="OITEMS" then
    ShopOpenOtherDB connection, getconfig("xOrderDb")
    exit sub
end if
if MyTable="MYCOMPANY" then
    ShopOpenOtherDB connection, getconfig("xOrderDb")
    exit sub
end if
if MyTable="AFFILIATES" then
    ShopOpenOtherDB connection, getconfig("xAffiliateDB")
    exit sub
end if
if MyTable="SEARCHRESULTS" then
    ShopOpenOtherDB connection, getconfig("xSearchDb")
    exit sub
end if
if MyTable="PROJECTS" then
    ShopOpenOtherDB connection, getconfig("xprojectDb")
    exit sub
end if
If getconfig("xothertables")<>"" then
     FindOtherdatabase newdatabase,MyTable     
     If newdatabase<>"" then
        ShopOpenOtherDB connection, newdatabase
        exit sub
     end if
end if        
ShopOpenDatabase connection
end sub
' Use to open other database
'
Sub ShopOpenOtherDB (connection, database)
dim mytable
If database="" then
     ShopOpendatabase connection
     exit sub
end if
OpenOtherdatabase connection,database,xdblocation,xdatabasetype
end sub

Sub LocateCustomerLastOrder(Customerid)
Dim rs
dim myconn
' See if customer stored separately
OpenOrderDb myconn
sql = "select * from orders where ocustomerid=" & customerid & " order by orderid desc" 
Set rs = myconn.Execute(SQL)
If Not rs.EOF Then
 strshipname=rs("oshipname")
 strshipaddress=rs("oshipaddress")
 strshiptown=rs("oshiptown")
 strshipzip=rs("oshipzip")
 strshipstate=rs("oshipstate")
 strshipcountry=rs("oshipcountry")
 strshipcompany=rs("oshipcompany")
 strshipmethodtype=rs("oshipmethodtype")
 strshipcost=rs("oshipcost")
 else
 strshipname=""
 strShipAddress=""
 strShipTown=""
 strShipZip=""
 strShipState=""
 StrShipCountry=""
 strshipCompany=""
 strShipMethodType=""
 strShipCost=""
end if

rs.close
set rs=nothing
ShopClosedatabase myconn
end sub
Sub CheckValidLogin
' everyone must login then make sure they have
If getconfig("xlogonrequired")="Yes" then
   If GetSess("Login")="" then
       responseredirect "shoploginforce.asp"
   end if
end if
If getconfig("xshopclosed")="Yes" then
   If Getsess("Login")="Force" then
      exit sub
   end if
   if getsess("shopadmin")="" then
      shoperror getlang("Langshopclosed")
   end if   
end if   
end sub

'
Sub ConvertNumber (oamount,iamount)
dim whole,comma, length
dim innumber
dim commapos
oamount=iamount
if getconfig("xlcid")="" then exit sub
oamount=csng(iamount)
exit sub
' old style follows
innumber =formatnumber(iamount,2)
length=len(innumber)
commapos=length-2
comma=mid(innumber,commapos,1)
if comma="." then exit sub
whole=""
If length > 3 then
   whole=mid(innumber, 1, length-3)
   whole=replace (whole,".", "")
end if
whole=whole & "." & right(innumber,2)
oamount=whole
end sub
Sub PerformNumberConversion
dim amount
ConvertNumber amount,GetSess("OrderTotal")
SetSess "Ordertotal", amount
If GetSess("smprice")<> "" then
  ConvertNumber amount,GetSess("Smprice")
  SetSess "Smprice", amount
end if
If Getsess("Taxes") <> "" then
  ConvertNumber amount,GetSess("Taxes")
  SetSess "Taxes",amount
end if
If Getsess("Discount") <> "" then
  ConvertNumber amount,GetSess("Discount")
  SEtSess "Discount", amount
end if
If Getsess("Handling") <> "" then
  ConvertNumber amount,GetSess("Handling")
  SetSess "Handling", amount
end if
end sub

Function DateDelimit (indate)
dim datedelim, newdate
datedelim="#"
if ucase(xdatabasetype)="SQLSERVER" or getconfig("xmysql")="Yes" then
  datedelim="'"
end if  
newdate=DateNormalize(indate)
'newdate=indate
dateDelimit  = datedelim & newdate & datedelim
end function
'
Function DateNormalize(indate)
Dim yyyy,mm,dd,newdate
yyyy=datepart("yyyy",indate)
mm= datepart("m",indate)
If len(mm)=1 then
   mm="0" & mm
end if   
dd=datepart("d",indate)
if len(dd)=1 then
  dd="0" & dd
end if  
newdate=yyyy & "-" & mm & "-" & dd
DateNormalize=newdate
end Function

Sub ParseRecord (record,words,wordcount,delimiter)
Dim pos 
Dim recordl
Dim bytex
Dim temprec
Dim maxwords
Dim i
maxwords = 10
temprec = record
Dim maxentries
pos = 1
wordcount = 0
' make sure word array is null
maxentries = UBound(words)
For i = 0 To maxentries - 1
   words(i) = ""
Next
recordl = Len(temprec)
' first eliminate leading blanks
Do
   bytex = Mid(temprec, pos, 1)
   While bytex = " " And pos <= recordl
     pos = pos + 1
     bytex = Mid(temprec, pos, 1)
   
   Wend
' copy word into word array
   While bytex <> delimiter And pos <= recordl
     words(wordcount) = words(wordcount) & bytex
     pos = pos + 1
     bytex = Mid(temprec, pos, 1)
     
   Wend
   wordcount = wordcount + 1
   pos = pos + 1
   If wordcount > maxentries Then Exit Sub
Loop Until pos > recordl
End Sub

Function ShopFormatCurrency (amount, decimalpoint)
' Handle 0 and garbage prices
dim tamount
tamount=amount
If  not isnumeric(tamount) then
   tamount=0
end if
if tamount=0 then
   if getconfig("xprice0")<>"" then
       shopformatcurrency=Getconfig("xprice0")
       exit function
   end if
end if       
If getconfig("XCurrencySymbol")="" then
   shopformatcurrency=formatCurrency (tamount, decimalpoint)
else
   shopformatcurrency=getconfig("XCurrencySymbol") & " " & formatNumber (tamount, decimalpoint)
end if   
end function
'
Sub CustCheckAdmin (customerid)
If GetSess("CustomerLogincid")="" Then
     responseredirect "shopcustadminlogin.asp"
end if
If Getsess("db")<>xdatabase then
    responseredirect "shopcustadminlogin.asp"
end if
customerid=getsess("CustomerloginCID")
End Sub
'
Sub ShopError (msg)
responseredirect "shoperror.asp?msg=" & Server.URLEncode (msg)
end sub

Sub FindOtherDatabase (database, table)
' look in othertables and otherdatabases to find database match the table
dim othertables(50),otherdatabase(50), j, dbcount, tablecount
database=""
If Getconfig("xotherdatabases")<>"" and getconfig("xothertables")<>""  then
   parserecord getconfig("xothertables"),othertables,tablecount,","
   parserecord Getconfig("xotherdatabases"),otherdatabase,dbcount,","
   for j=0 to tablecount-1
        if table=ucase(Othertables(j)) then
            database=otherdatabase(j)
        end if
   next
end if            
end sub
Sub CancelOrderRecord (dbc, orderid)
If getconfig("XKeepCanceledOrders")="Yes" then
   If getconfig("XkeepCanceledItems")<>"Yes" Then
      dbc.execute "delete from oitems where orderid = " & clng(orderid)
   end if   
   dbc.execute "update orders set ocardtype='" & getlang("langcanceled")  & "',canceled=1" & " where orderid = " & clng(orderid) 
else
   dbc.execute "delete from oitems where orderid = " & clng(orderid)
   dbc.execute "delete from orders where orderid = " & clng(orderid)
end if
end sub

Sub OpenRecordSet (conn, irs, isql)
Set irs=conn.execute(isql)
end sub

Sub CloseRecordSet (irs)
irs.close
set irs=nothing
end sub

Sub Adjustdate (newdate)
dim hh, xtimedifference
xtimedifference=getconfig("xtimedifference")
hh=hour(time())
hh=clng(hh)+clng(xtimedifference)
if hh>=24 then
    newdate=DateAdd("d",1,Date())
elseif hh<0 then
    newdate=DateAdd("d",-1,Date()) 
else    newdate=date()
end if 
' june 6
newdate=cdate(newdate)
'newdate=formatdatetime(newdate,vbshortdate)
end sub
'
Sub AdjustTime (newtime)
newtime=DateAdd("h",Getconfig("xtimedifference"),Time()) 
newtime=formatdatetime(newtime,vbshorttime)
end sub

Sub CustomerGetFieldsRS (rs)
dim words,wordcount,customervalues,i, customerfieldcount
redim words(getconfig("xCustomermaxotherfields"))
on error resume next
if getconfig("xCustomerOtherFields")="" then exit sub
Parserecord getconfig("xcustomerOtherFields"), words, wordcount,","
Customervalues=Getsess("Customervalues")
CustomerFieldcount=Getsess("CustomerFieldcount")
If not isarray(customervalues) then
     redim customervalues(wordcount)
     SetSess "customerFieldcount",wordcount
     customerfieldcount=wordcount
end if
CustomerFieldcount=Getsess("CustomerFieldcount")
for i = 0 to wordcount-1
   Customervalues(i)=rs(words(i))
   if isnull(customervalues(i)) then
       customervalues(i)=""
   end if
next
SetSessA "Customervalues",customervalues
end sub
Sub CheckValidOrderNumber
If xordernumber="" or xordernumber="0" then
    shoperror "Order number must be entered into shop$config.asp. See $readme.txt "
end if
end sub

Sub ValidateQuantity (quantity)
if not isnumeric(Quantity) then
         quantity=1
end if 
if quantity< 0 then
       quantity=-quantity
end if 
If getconfig("xallowdecimalquantity")<>"Yes" then
  If quantity<1.0 then
      quantity=1
  end if 
  quantity=clng(quantity)
   if clng(quantity)>clng(getconfig("xproductquantitylimit"))  then
     quantity=getconfig("xproductquantitylimit")
   end if   
else
  if csng(quantity)>csng(getconfig("xproductquantitylimit"))  then
     quantity=getconfig("xproductquantitylimit")
   end if   
end if
end sub

Sub GetCustomerCookie
if getconfig("xcookielogin")<>"Yes" then exit sub
restorecustomerdetailscookie
end sub

Function Timedelimit(itime)
dim delimiter
delimiter="'"
timedelimit =delimiter & itime & delimiter
end function

Sub CheckDatabaseOpen (conn)
dim msg
If conn.state=adStateOpen  then
   If Getconfig("Init")<>"Yes" then
     SetConfig "Init",""
     setsess "init",""
     shopinit
   end if   
   exit sub
end if   
msg=getlang("LangDatabaseOpenError") & "<br>"
msg=msg& "<br>" & getsess("Openerror")
shoperror msg
end sub

Function ShopFormatNumber (amount, decimalpoint)
shopformatnumber=formatNumber (amount, decimalpoint)
end function

'*************************************************
' VP-ASP 4.0
' update customer information
' Update Order
' Customer Session variables
' Get product values
'****************************************************
Sub UpdateContact()
if getconfig("xMYSQL")="Yes"  then
   MYSQLUPdatecontact
   exit sub
end if   
Dim dbc
Dim DoUpdate
DoUpdate=""
'on error resume next
OpenCustomerDb dbc
If GetSess("CustomerId")<>"" and GetSess("Lastname") <> ""  and getconfig("xAllowCustomerUpdates")="Yes" then
        Set objRS = Server.CreateObject("ADODB.Recordset")
        sql="select * from customers where contactid=" & getsess("customerid") 
        sql=sql & " and lastname='" & replace(getsess("lastname"),"'","''") & "'"
        objRS.open SQL, dbc, adOpenKeyset, adLockOptimistic, adcmdText
        if not ObjRS.eof  then
            DoUpdate="True"
            objRS.update
        else
            objRs.close
            set objRS=nothing 
        end if     
     end if

If Doupdate="" then
     Set objRS = Server.CreateObject("ADODB.Recordset")
     objrs.open "customers", dbc, adopenkeyset, adlockoptimistic, adcmdtable 
     objRS.AddNew
end if
	objrs("firstname") = strfirstname
	objrs("lastname") = strlastname
	objrs("address") = straddress
	objrs("city") = strcity
	updatecustfield "state",strstate
	updatecustfield "postcode",strpostcode
	updatecustfield "country",strcountry
	updatecustfield "company",strcompany
	updatecustfield "phone",strphone
	updatecustfield "workphone",strworkphone
	updatecustfield "mobilephone",strmobilephone
	updatecustfield "fax",strfax
	updatecustfield "email",stremail
        updatecustfield "website",strwebsite
        updatecustfield "password",strpassword1
        updatecustfield "maillist",blnmaillist
        updatecustfield "cookiequestion",blncookiequestion
        updatecustfield "vatnumber",strvatnumber    ' 4.50
        updatecustfield "userid",strcustuserid      '5.00
        updatecustfield "hearaboutus",strhearaboutus      '5.00
        if getconfig("xcustomerotherfields")<>"" then
           customerupdatefields objrs              ' update additional 
        end if   
        objrs.update
        strcustomerid=cstr(objrs("contactid"))   
        closerecordset objrs
        shopclosedatabase dbc
        updatecustomersessiondata             
    	setsess "customerid",strcustomerid
end sub	
Sub UpdateCustField (fieldname,fieldvalue)
on error resume next
if fieldvalue="" then
     exit sub
end if
If getconfig("xdebug")="Yes" then
   Debugwrite fieldname & " " & fieldvalue & "<br>"
end if 
objRS(fieldname)=fieldvalue
end Sub

'***********Get Product Values
Sub ProductGetValues(objRs)
Dim Newprice
On Error Resume next
' get products values from recordet already open
' Get values for a single product
memcdescription = objrs("cdescription")
'memextdesc=objrs("extendeddesc")
lngcatalogid = objrs("catalogid")
strccode = objrs("ccode")
strcname = objrs("cname")
curcprice = objrs("cprice")
strcimageurl = objrs("cimageurl")
If isnull(strcimageurl) then strcimageurl=""
datcdateavailable = objrs("cdateavailable")
lngcstock = objrs("cstock")
lngccategory = objrs("ccategory")
strcategory = objrs("category")
strmfg = objrs("mfg")
strdescurl=objrs("cdescurl")
if isnull(objrs("features")) then
  strfeatures=""
else
  strfeatures=objrs("features")
end if
strbuttonimage=objrs("buttonimage")
strweight=objrs("weight")
If isnull(strweight) then strweight=""
strpother1=objrs("pother1")
strpother2=objrs("pother2")
strpother3=objrs("pother3")
strpother4=objrs("pother4")
strpother5=objrs("pother5")
strretailprice=objrs("retailprice")
strspecialoffer=objrs("specialoffer")
strallowusertext=objrs("allowusertext")
strtemplate=objrs("template")
strextendedimage=objrs("extendedimage")
strtemplate  = objrs("template")
strselectlist  = objrs("selectlist")
strproductuserid=objrs("userid")
strlevel3=objrs("level3")
strlevel4=objrs("level4")
strlevel5=objrs("level5")
strminimumquantity=objrs("minimumquantity")
if isnull(strminimumquantity) then
   strminimumquantity=0
end if   
strsupplierid=objrs("supplierid")
if isnull(strsupplierid) then
  strsupplierid=0
end if  
strcrossselling=objrs("crossselling")
strgroupfordiscount=objrs("groupfordiscount")
strclanguage=objrs("clanguage")
strdownload=objrs("orderdownload")
strattachment=objrs("orderattachment")
strproductmatch=objrs("productmatch")
strcustomermatch=objrs("customermatch")
strpoints=objrs("points")  
strpointstobuy=objrs("pointstobuy")  
strprice2=objrs("price2")  
strprice3=objrs("price3")    
if isnull(strgroupfordiscount) then
    strgroupfordiscount=""
end if 
strmaximumquantity=objrs("maximumquantity")
strfrontpage=objrs("frontpage")
if isnull(strmaximumquantity) then
   strmaximumquantity=""
end if
dim dualpricefield
' allows dual price to come directly from product record
strcdualprice=""
dualpricefield=getconfig("xdualpricefield")
if dualpricefield<>"" then
   strcdualprice=objrs(dualpricefield)
   If isnull(strcdualprice) then
      strcdualprice=""
   end if
end if
'      
newprice=curcprice
curoriginalprice=curcprice
shopcustomerprices objrs,lngcatalogid, lngccategory, curcprice, newprice, lngdiscount
CurCPrice=NewPrice
ProductFieldvalid=True
end sub

'*********************************************************'
'  Takes customer details and stores them in local variables
'
'******************************************************
Sub GetCustomerSessionData()
if getsess("lastname")<> "" then
	strcustomerid = getsess("customerid")
	strfirstname = getsess("firstname")
	strlastname = getsess("lastname")
	straddress = getsess("address")
	strcity = getsess("city")
	strstate = getsess("state")
	strpostcode = getsess("postcode")
	strcountry = getsess("country")
	strcompany = getsess("company")
	strwebsite = getsess("website")
	strphone = getsess("phone")
	strworkphone = getsess("workphone")
	strmobilephone = getsess("mobilephone")
	strfax = getsess("fax")
	stremail = getsess("email")
        strshipname=getsess("shipname")
        strshipaddress=getsess("shipaddress")
        strshiptown=getsess("shiptown")
        strshipzip=getsess("shipzip")
        strshipstate=getsess("shipstate")
        strshipcountry=getsess("shipcountry")
        strshipcompany=getsess("shipcompany")
        strshipmethodtype=getsess("shipmethod")
        strshipcost=getsess("smprice")
        strshipcomment=getsess("shipcomment") 
        strdiscount=getsess("custdiscount")
        strgiftcertificate=getsess("giftcertificate")
        blnmaillist=getsess("blnmaillist")
        blncookieQuestion=getsess("blncookiequestion")
        strcustomertype=getsess("customertype")
        strvatnumber=getsess("vatnumber")
        strhearaboutus=getsess("hearaboutus")
        exit sub
end if
end sub

'*********************************************************
' Takes local variables and stores them into session variables
'************************************************************
'
Sub UpdateCustomerSessionData
	SetSess "Firstname", strFirstname 
	SetSess  "Lastname", strLastname  
	SetSess "Address", strAddress  
	SetSess "City", strCity 
	SetSess "State", strState 
	SetSess "PostCode", strPostCode 
	SetSess "Country", strCountry 
	SetSess "Company", strCompany 
	SetSess "Website", strWebsite 
	SetSess "Phone", strPhone 
	SetSess "Workphone", strWorkphone 
	SetSess "Mobilephone", strMobilephone 
	SetSess "Fax", strFax
	SetSess "Email", strEmail
        SetSess "shipname", strshipname
        SetSess "ShipAddress", strShipaddress
        SetSess "ShipTown", strshiptown
        SetSess "ShipZip", strShipZip
        SetSess "ShipState", strShipstate
        SetSess "ShipCountry", strShipcountry
        SetSess "ShipCompany", strShipcompany
        SetSess "ShipMethodType", strshipmethod
        SetSess "ShipCost", strShipCost
        SetSess "smprice", strShipCost
        SetSess "CustomerID", strCustomerID
        SetSess "ShipComment", strshipcomment
        SetSess "Custdiscount", strdiscount
        SetSess "GiftCertificate",strgiftcertificate
        SetSess  "BlnMailList",blnMailList
        SetSess  "BlnCookieQuestion",blnCookieQuestion
        SetSess  "Customertype",strcustomertype
        SetSess  "vatnumber",strvatnumber
        SetSess  "hearaboutus",strhearaboutus
        If getconfig("xCookieLogin")="Yes" and blnCookieQuestion=True then
           SaveCustomerDetailsCookie
        end if
 end sub
'******************************************************
' Locate customer from database'
'*****************************************************
Sub LocateCustomer (LastName, emailvalue, passwordvalue)
Dim rs, temail
dim myconn
dim templastname
dim whereok, productgroup
if lastname<>"" then
   templastname=replace(lastname,"'","''")
end if
temail=emailvalue
' See if customer stored separately
OpenCustomerDb myconn
sql = "select * from customers where "
whereok=""
If lastname<>"" then
     sql=sql & whereok &  " lastname='" & templastname & "'"
     whereok = " AND "
end if
if emailvalue<> "" then
  If getconfig("xcustomeruserid")<>"Yes" then  
     SQL = SQL & whereok & " email='" & temail & "'"
  else
        SQL = SQL & whereok & " userid='" & temail & "'"
  end if      
end if
If passwordvalue<>"" then
  SQL = SQL & " AND " & " password='" & passwordvalue & "'"
end if
'debugwrite sql
Set rs = myconn.Execute(SQL)
If Not rs.EOF Then
 strfirstname = rs("firstname")
 strlastname = rs("lastname")
 straddress = rs("address")
 strcity = rs("city")
 strstate = rs("state")
 strpostcode = rs("postcode")
 strphone = rs("phone")
 stremail = rs("email")
 strfax = rs("fax")
 if isnull(strfax) then strfax=""
 strwebsite=rs("website")
 if isnull(strwebsite) then strwebsite=""
 strmobilephone=rs("mobilephone")
 if isnull(strmobilephone) then strmobilephone=""
 strworkphone=rs("workphone")
 if isnull(strworkphone) then strworkphone=""
 strcountry = rs("country")
 if isnull(strcountry) then strcountry=""
 strcompany = rs("company")
 if isnull(strcompany) then strcompany=""
 lnglogincount=rs("logincount")
 strcustomerid=cstr(rs("contactid")) 
 strdiscount=rs("discount")
 blnmaillist=rs("maillist")
 blncookiequestion=rs("cookiequestion")
 strvatnumber=rs("vatnumber")
 strhearaboutus=rs("hearaboutus")
 ' 4.50
 if isnull(strvatnumber) then strvatnumber=""   
 If isnull(blncookiequestion) then
    blncookiequestion=True
 end if   
 if getconfig("xCustomerOtherfields")<>"" then
      CustomerGetFieldsRS rs    
 end if   
 If Getconfig("xproductmatchcustomer")="Yes" then
   productgroup=rs("productgroup")
   if isnull(productgroup) then
      productgroup=""
   end if
   setsess "Customerproductgroup",productgroup
 end if
' march 19 modification  
  dim customeridentifier
  customeridentifier=getconfig("xcustomerpriceidentifier")
  If customeridentifier="" then
     customeridentifier="contacttypeid"
   end if
   strcustomertype=rs(customeridentifier)
   if isnull(strcustomertype) then
       strcustomertype=""
   end if
   setsess "customertype",strcustomertype
   
' locatecustomerlastorder  strcustomerid
else
   strCustomerid=""
end if
rs.close
set rs=nothing
ShopClosedatabase myconn
end sub

'********************************************************
' Reset customer session data
'********************************************************
Sub ResetCustomerSessionData
	strFirstname = ""
	strLastname = ""
	strAddress = ""
	strCity = ""
	strState = ""
	strPostCode = ""
	strCountry = ""
	strCompany = ""
	strWebsite = ""
	strPhone = ""
	strWorkphone = ""
	strMobilephone = ""
	strFax = ""
	strEmail = ""
	strComments = ""
        strDiscount=""
        strCustomerid=""
        strvatnumber=""
        UpdateCustomerSessionData
        If getconfig("xCustomerOtherFields")<>"" then
         SetSess "CustomerValues",""
         SetSess "customerfieldcount",""
        end if
        If getconfig("xShippingOtherFields")<>"" then
         SetSess "ShippingValues",""
         SetSess "Shippingfieldcount",""
        end if
        setsess "customertype",""  
        setsess "shipmessage",""
        setsess "login",""
end sub

'**********************************************************
' * add an order to the database
'***********************************************************
' ********* AD ORDER Everything is now available
Sub ShopAddOrder
if getconfig("xmysql")="Yes" then
   MYSQLAddOrder
   exit sub
end if   
Dim arrCart, scartItem
Dim dbc
Dim oid, sqlo
Dim i
dim newdate, newtime
dim ipaddress
arrCart = GetSessA("CartArray")            ' get shopping cart data
scartItem = GetSess("CartCount")
ShopopenOtherdb  dbc, getconfig("xorderdb")
Set rsorder = Server.CreateObject ("adodb.recordset")
If GetSess("Orderid")<>"" then
  CancelOrderRecord  dbc,session("orderid") 
  SetSess "Orderid",""
end if
rsorder.Open "orders", dbc, adOpenKeyset, adLockPessimistic, adCmdTable
GetCustomerSessionData                 ' make sure we have session into local
Errors=""                               ' no errors 
If getconfig("xConvertEuropeanNumbers")="Yes" then
      PerformNumberConversion
end if
	rsorder.AddNew
	rsorder("ocustomerid") = strCustomerid
	If getconfig("xTimeDifference")="" then 
	   rsorder("odate") = Date
	else
	  adjustdate newdate
	  rsorder("odate") = newdate
	  adjusttime newtime
	  rsorder("otime") = newtime
	end if
	updatefield "orderamount", getsess("ordertotal")
        updatefield "olastname",strlastname
        updatefield "ofirstname",strfirstname
	updatefield "oemail",stremail
	updatefield "oaddress",straddress
	updatefield "ocity",strcity
	updatefield "opostcode",strpostcode
	updatefield "ostate",strstate
	updatefield "ophone", strphone
	updatefield "oshipmethodtype",getsess("shipmethod")
        updatefield "oshipcost",getsess("smprice")
        updatefield "otax",getsess("taxes")     ' 2.13 fix
        updatefield "ocountry",strcountry
        updatefield "ofax", strfax
        updatefield "ocompany", strcompany
        updatefield "ocomment",strshipcomment
        updatefield "oshipname", getsess("shipname")
	updatefield "oshipaddress",getsess("shipaddress")
	updatefield "oshiptown",getsess("shiptown")
	updatefield "oshipzip", getsess("shipzip")
	updatefield "oshipstate",getsess("shipstate")
	updatefield "oshipcountry",getsess("shipcountry")
        updatefield  "oshipcompany", getsess("shipcompany")
        updatefield  "odiscount", getsess("discount")
        updatefield  "ohandling", getsess("handling")
        updatefield  "oaffid", getsess("affid")
        updatefield  "canceled", false
        updatefield "oerrors", errors          'write errors to database
        If getconfig("xdualprice")="Yes" then
          Updatefield "odualtotal",GetSess("dualtotal")
          Updatefield "odualshipping",GetSess("dualshipping")
          Updatefield "odualtaxes",GetSess("dualtaxes")
          Updatefield "odualdiscount",GetSess("dualdiscount")
          Updatefield "odualhandling",GetSess("dualhandling")
        end if 
        updatefield  "coupon", getsess("coupon")     ' saved order info
        updatefield  "coupondiscount", getsess("coupondiscount")     ' saved order info
        updatefield  "coupondiscountdual", getsess("coupondiscountdual")     ' saved order info
        updatefield  "giftcertificate",getsess("giftcertificate")
        updatefield  "giftamountused",getsess("giftamountused")
        updatefield  "giftamountuseddual",getsess("giftamountuseddual")
        ipaddress=request.servervariables("REMOTE_ADDR")
        updatefield  "ipaddress",ipaddress
        updatefield  "canceled",0
        updatefield  "hackeryesno",0
        updatefield  "oprocessed",0
        updatefield  "vatnumber",getsess("vatnumber")
        If Getconfig("xcustomerotherfieldsinorder")="Yes"  then
           if getconfig("xcustomerotherfields")<>"" then
             customerupdatefields rsorder
           end if
        end if
        if getconfig("xshippingotherfields")<>"" then
             shippingupdatefields rsorder
        end if
        updatefield  "shipmessage",Getsess("Shipmessage") 
        updatefield  "hearaboutus",Getsess("hearaboutus")   
	rsorder.Update
' Fix for Concurrency 
	oid = rsorder("orderid")
        SetSess "orderid",oid
        SetSess "oid", oid 
	rsorder.Close
	set rsorder=nothing
' End Fix for concurrency
' add Items To Database
        Dim rsitem,productaddress
	Set rsitem = Server.CreateObject ("adodb.recordset")
	rsitem.Open "oitems", dbc, adOpenKeyset, adLockOptimistic , adcmdtable
	For i = 1 To scartItem
		rsitem.AddNew
		rsitem("orderid") = oid
		rsitem("catalogid") = arrcart(cproductid,i)
		rsitem("numitems") = arrcart(cquantity,i)
		rsitem("itemname") = arrcart(cproductname,i)
		rsitem("unitprice") = arrcart(cunitprice,i)
                rsitem("dualprice") = arrcart(cdualprice,i)
                If arrcart(cProductfeatures,i)<>"" then
                   rsitem("features") = arrcart(cProductfeatures,i)
                end if   
                if isnumeric (arrcart(csupplierid,i)) then
                  rsitem("supplierid") = arrCart(csupplierid,i)
                else
                    rsitem("supplierid") = 0
                end if    
                if getconfig("XdeliveryAddress")="Yes" then
                   ConvertDeliverytoString arrCart(cDelivery,i), ProductAddress
                   If ProductAddress="" then 
                      ProductAddress=NULL
                   end if   
                   rsitem("address")=ProductAddress
                end if   
		rsitem.Update
	Next
	rsitem.Close
        set rsitem=nothing
        ShopCloseDatabase dbc
End Sub	
' Update order Field
Sub UpdateField (field,myvalue)
dim tlen,ttype, tvalue
if myvalue="" then
     exit sub
end if
tvalue=myvalue
tlen=rsorder(field).DefinedSize
ttype=rsorder(field).type
on error resume next
if ttype=202 then
  if len(tvalue)>tlen  then
    tvalue=left(tvalue,tlen)
  end if  
end if  
if getconfig("xdebug")="Yes" then
  debugwrite field & " " & myvalue & "<br>"
end if
rsorder(field)=tvalue
if err.Number> 0 then
    Errors=Errors & "Order data failed " & field & "=" & myvalue & "<br>"
    SetSess "Oerrors", errors 
end if
end sub 

'*****************************************************
' Paging navigation bar
'*****************************************************
sub PageNavBar(sql)
dim scriptname,counterstart,pad,counterend,counter,ref,mysql
mysql=sql
SetSess "sqlquery",sql
      pad=""
      scriptname=request.servervariables("script_name")
      response.write PageNavTable & PageNavRow
      response.write PageNavColumn & PageNavFont
      if (mypage mod 10) = 0 then
       counterstart = mypage - 9
      else
       counterstart = mypage - (mypage mod 10) + 1
      end if
      counterend = counterstart + 9
      if counterend > maxpages then counterend = maxpages
      if counterstart <> 1 then
       ref="<a href='" & scriptname
       ref=ref & "?page=" & 1
       ref=ref & "'>" & getlang("LangFirst") & "</a>&nbsp;:&nbsp;"
       Response.Write ref
       ref="<a href='" & scriptname
       ref=ref & "?page=" & (counterstart - 1)
       ref=ref & "'>" & getlang("langPrevious") & " </a>&nbsp;"
       Response.Write ref
      end if
      Response.Write "["
      for counter=counterstart to counterend
       If counter>=10 then
       pad=""
       end if
       if cstr(counter) <> mypage then
       ref="<a href='" & scriptname
       ref=ref & "?page=" & counter
'      ref=ref & "&pagesize=" & mypagesize
'      ref=ref & "&sqlQuery=" & server.URLencode(mySQL)
       ref=ref & "'>" & pad & counter & "</a>"
       else
       ref="<b>" & pad & counter & "</b>"
       end if
       response.write ref
       if counter <> counterend then response.write " "
      next
      Response.Write "]"
      if counterend <> maxpages then
       ref="&nbsp;<a href='" & scriptname
       ref=ref & "?page=" & (counterend + 1)
       ref=ref & "'>" & getlang("langNext") & "</a>"
       Response.Write ref

       ref="&nbsp;:&nbsp;<a href='" & scriptname
       ref=ref & "?page=" & maxpages
       ref=ref & "'>" & getlang("langLast") & "</a>"
       Response.Write ref
      end if
      response.write "<br>" & PageNavFontEnd 
      response.write PageNavTableEnd
end sub
'


'*****************************************************
' Paging navigation bar
'*****************************************************
sub PageNavBarNext(sql)
dim scriptname,counterstart,pad,counterend,counter,ref,mysql
dim nextpage, prevpage
mysql=sql
SetSess "sqlquery",sql
      pad=""
      scriptname=request.servervariables("script_name")
      response.write PageNavTable & PageNavRow
      response.write PageNavColumn & PageNavFont
      nextpage=mypage+1
      prevpage=mypage-1 
      if prevpage>=1  then
             ref="<a href='" & scriptname
           ref=ref & "?page=" & prevpage & "'>"
           If getconfig("xbuttonpreviouspage")=""  then
              ref=ref & getlang("langpreviouspage")
           else
              ref=ref & "<img border='0' src='" & getconfig("Xbuttonpreviouspage") & "'>"
           end if    
           ref=ref &  "</a>&nbsp;&nbsp;"
           Response.Write ref
      end if     
      If Nextpage=< maxpages then
           ref="<a href='" & scriptname
           ref=ref & "?page=" & nextpage &  "'>"
           If getconfig("xbuttonnextpage")=""  then
              ref=ref & getlang("langnextpage") 
           else
              ref=ref & "<img border='0' src='" & getconfig("Xbuttonnextpage") & "'>"
           end if    
           ref=ref & "</a>&nbsp;&nbsp;"
           Response.Write ref
      end if
      response.write "<br>" & PageNavFontEnd 
      response.write PageNavTableEnd
end sub
Sub CustomerUpdateFields (rs)
dim words,wordcount,customervalues,i, customerfieldcount
on error resume next
if getconfig("xCustomerOtherFields")="" then exit sub
redim words(Getconfig("xCustomermaxotherfields"))
Customervalues=Getsess("Customervalues")
If not isarray(customervalues) then exit sub
CustomerFieldcount=Getsess("CustomerFieldcount")
Parserecord getconfig("xcustomerOtherFields"), words, wordcount,","
for i = 0 to wordcount-1
   If customervalues(i)<> "" then 
     ' debugwrite words(i) & "=" & customervalues(i)
      rs(words(i))=Customervalues(i)
    else
      rs(words(i))=NULL
   end if   
next
end sub
'
Function Shopdateformat (iDate, itype)
  Dim strDate
  Dim intTrim
  intTrim = 1
  if len(itype) = 0 Then
    Shopdateformat = ""
  Else
  'Enter recursive function to format date
  Select Case Left(itype,1)
  Case "d"
    if Mid(itype, 2, 1) = "d" Then
      strDate = weekdayname(weekday(iDate)) & " " & datepart("d",iDate)
      intTrim = 2
    Else
      strDate = day(iDate)
    End If
  Case "m"
    if Mid(itype, 2, 1) = "m" Then
      strDate = monthname(month(iDate))
      intTrim = 2
    Else
      strDate = month(iDate)
    End If
  Case "y"
    if Mid(itype, 2, 3) = "yyy" Then
      strDate = year(iDate)
      intTrim = 4
    ElseIf Mid(itype, 2, 1) = "y" Then
      strDate = Right(year(iDate), 2)
      intTrim = 2
    Else
   strDate = Right(year(iDate), 2)
    End If
  Case " "
    strDate = " "
  Case "/"
    strDate = "/"
  Case "-"
    strDate = "-"
  Case "."
    strDate = "."
  Case Else
    Response.Write "<BR>** Error in date format string **"
  End Select
 Shopdateformat = strDate & Shopdateformat(iDate, Right(itype, Len(itype) -intTrim))
End If
End Function
'
Sub ShippingUpdateFields (rs)
dim words,wordcount,shippingvalues,i, shippingfieldcount
on error resume next
if getconfig("xShippingOtherFields")="" then exit sub
redim words(Getconfig("xCustomermaxotherfields"))
shippingvalues=Getsess("Shippingvalues")
If not isarray(shippingvalues) then exit sub
shippingFieldcount=Getsess("shippingFieldcount")
Parserecord getconfig("xshippingOtherFields"), words, wordcount,","
for i = 0 to wordcount-1
   If shippingvalues(i)<> "" then 
      rs(words(i))=shippingvalues(i)
    else
      rs(words(i))=NULL
   end if   
next
end sub
Sub Shopbutton (buttonimage, buttontext,buttonname)
dim tempname
tempname=buttonname
if tempname="" then
  tempname="Action"
end if  
If buttonimage="" then
   Response.Write("<input type=submit name=" & tempname & " value=""" & buttontext & """>")
else
    Response.Write("<input type=image border='0' name=" & tempname & " src=""" & buttonimage & """>")
end if    
end sub

Sub ShopbuttonReset (buttonimage, buttontext,buttonname)
dim tempname
tempname=buttonname
if tempname="" then
  tempname="Action"
end if  
If buttonimage="" then
   Response.Write("<input type=reset name=" &tempname & " value=""" & buttontext & """>")
else
   Response.Write("<img border='0' src='" & buttonimage & "' onclick='document.form1.reset()'>")  
end if    
end sub
'*******************************************************************************
' Input is a record set field. if it is null, then set to null
'******************************************************************************
Function Getrsitem(fieldvalue)
if isnull(fieldvalue) then
   getrsitem=""
else
   geTRsitem=fieldvalue
end if
end function 
sub ShopCheckLicense
end sub
'
Sub ShopCheckInstall (conn)
end sub

' By change the shoppage_header and trailer you can make shop look specific to your merchant
Sub PrintPageHeader
%>
<!-- #include file="shop_printheader.htm" -->
<%
end sub
Sub PrintpageTrailer
%>
<!-- #include file="shop_printtrailer.htm" -->
<%
end sub
'
sub shoplicenseError
end sub
'********************************************************************
' See if hacker is trying to run something 
'*****************************************************************
Sub CleanseMessage (msg, rc)
dim lmsg, pos
lmsg=lcase(msg)
pos=instr(lmsg, "<script>")
If pos> 0 then
   rc=4
else
   rc=0
end if
end sub
'***********************************************************************
Sub ShopWriteError (msg)
response.write "<br>" & errorfontstart & msg & errorfontend & "<br>"
end sub

'***********************************************************************
Sub ShopWriteHeader (msg)
response.write largeinfofont & msg & largeinfoend & "<br>"
end sub

%>