<%Response.buffer=TRUE%>
<!-- #include file="shop$config.asp" -->
<!-- #include file="shop$version.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" -->
<!-- #include file="shoptranslate.asp" -->
<!-- #include file="shopproductsubs2.asp" -->
<!-- #include file="shopsearchsubs.asp" -->
<!-- #include file="shopfileio.asp" -->
<%
const xAccessOLE="Yes"        ' Yes uses Jet Ole 4.0 for Access
const xsqloledb="No"            ' use SQL Server standard 

'VP-ASP 6.50 - advanced support for SQL Server 2005
const xsqlnative="No"            ' use SQL Server 2005 native client

'*******************************************************************
'  Almost all common routines are here and in shopdbsubs.asp
'  This routine is included in all other shop routines
'  VP-ASP 6.50
'  Jan 1, 2006          Fix generateselev to add quotes
'******************************************************
' Shopping cart attributes
'******************************************************
const cMaxCartAttributes=24
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

'VP-ASP 6.50 - allow customers to upload images
const cuploadimagerequired=22
const cgraphicname1=23
const ccountgraphics=24

'*****************************************************
' 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      

'VP-ASP 6.50 - added extra image fields
dim strimageextra1
dim strimageextra2
dim strimageextra3
dim strimageextra4
dim strimageextra5

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
dim strtaxfree, strfreeshipping  '5.50
dim strfeaturedflag		'6.50
dim strcustomerimage		'6.50
dim strrmadays		'6.50
' 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 straddress2, strshipaddress2, strinventoryproducts
'VP-ASP 6.08
dim strcoupon,strcoupondiscount

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
' VP-ASP 6.0
Dim rscurr

'VP-ASP 6.50
dim goToQS

'VP-ASP 6.08 - "Remember" current page
SetSess "convertBackBackpage",GetSess("convertBackpage")
SetSess "convertBackpage",GetSess("convertCurrentpage")

  'VP-ASP 6.50 - clean querystring before including in session
  if request.servervariables("query_string")<>"" then
  	dim newcurrentpage
    	
	if request.QueryString > "" then
		dim theQuerystring, thing, qsdelimiter

		qsdelimiter = "?"
		theQuerystring = split(request.QueryString, "&")

		for each thing in theQueryString
			if len(thing) > 0 then
				if left(thing, instr(thing, "=") - 1) <> "CID" AND left(thing, instr(thing, "=") - 1) <> "goback" then
					goToQS = goToQS & qsdelimiter & thing
					if qsdelimiter = "?" then qsdelimiter = "&"
				end if
			end if
		next
	end if
	
	newcurrentpage = request.servervariables("script_name") & gotoqs

	SetSess "convertCurrentpage", newcurrentpage
  else
    SetSess "convertCurrentpage",request.servervariables("script_name")
  end if
  
'VP-ASP 6.09 - if no country loaded, then set to default
IF getSess("CID") = "" THEN
 'VP-ASP 6.50 - don't do this if using diag page
 if (instr(lcase(request.ServerVariables("script_name")), "diag_dbtest.asp") > 0) OR (instr(lcase(request.ServerVariables("script_name")), "convert650.asp") > 0) then
 	'do nothing
 else
 GetCurrency
end if
end if

'*******************************************************
' 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 

'VP-ASP 6.50 - add support for Access 2007
if databasetype="ACCESS2007" then
   ProcessAccess2007 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

'******************************************************
' VP-ASP 6.50  - Add support for Access 2007 Database
Sub ProcessAccess2007Open(connection)
dim dblocation
dim strconn
dim database
database=GetSess("db") & ".accdb"          ' database name
dblocation=GetSess("dblocation")' location 
If dblocation<>"" then
     database = GetSess("dblocation") & "\" & database
end if
   strconn = "Provider=Microsoft.ACE.OLEDB.12.0;persist security info=false;data source="  & Server.MapPath(database)
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
dim strconn
varServerIP = xSQLServer
varUserName = xSQLUser
varPassword = xSQLPwd
varDataBaseName = GetSess("db")
If xSQLOLEDB="Yes" then 
  strconn="Provider=sqloledb;" & "Source=" & varServerIP & ";" & "database=" & varDataBaseName & ";" & "UID=" & varUserName & ";" &  "Password=" & varPassword & ";" 
else  
	'VP-ASP 6.50 - advanced support for SQL Server 2005
	if xSQLnative = "Yes" then
		strconn= "DRIVER={SQL Native Client}; Server=" & varServerIP & "; Database=" & varDataBaseName & "; UID=" & varUserName & "; PWD=" & varPassword
	else
  		strconn= "DRIVER={SQL Server}; Server=" & varServerIP & "; Database=" & varDataBaseName & "; UID=" & varUserName & "; PWD=" & varPassword'
  	end if
end if  
Connection.Open strconn
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 "Couponaffid",""
setsess "shipmessage",""

'VP-ASP 6.09 - remove registry from session when order cancelled
if REGISTRANTID <> "" Then
	setsess REGISTRANTID,""
end if

'VP-ASP 6.50 - add flag to order to say customer has agreed to terms
setsess "blnlicense",""

'VP-ASP 6.50 - allow customer to upload images to order
setsess "uploadimage", ""
setsess "UploadFilename", ""
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 
if not isnumeric(id) then
   rc=4
   exit sub
end if         
dim dbc
dim productql
dim rsitem
ShopOpenDataBaseP 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, dbc
   GetNameInCart rsitem, dbc          ' 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 
'shoperror  "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
'VP-ASP 6.50 - broadened defintion of IF statement to cover cases where xmysql hasn't been set
if ucase(xdatabasetype) = "MYSQL" OR  ucase(xdatabasetype) = "MYSQL351" OR 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
	if isnumeric(mypagesize) then
   rstemp.pagesize=mypagesize
	end if
   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="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 cint(count)-1
  'VP-ASP 6.08 - if this option has no name, then don't show it
  if iFieldnames(i) > "" then

	'VP-ASP 6.50 - support for having a default selected shipping method
	dim tempcomparevalue
	tempcomparevalue = cstr(ifieldvalues(i))
	tempcomparevalue = replace(tempcomparevalue, """","")
	if instr(tempcomparevalue, "[") > 0 then
		tempcomparevalue = left(tempcomparevalue, instr(tempcomparevalue, "[") - 2)
	end if

	dim tempcurrentvalue
	tempcurrentvalue = cstr(currentvalue)
	tempcurrentvalue = replace(tempcurrentvalue, """","")
	if instr(tempcurrentvalue, "[") > 0 then
		tempcurrentvalue = left(tempcurrentvalue, instr(tempcurrentvalue, "[") - 2)
	end if
	
	response.write tempcurrentvalue = tempcomparevalue

   If tempcurrentvalue= tempcomparevalue then
      response.write "<option value=""" & ifieldvalues(i) & """ selected=""selected"">" &  iFieldnames(i) & "</option>" & vbcrlf
   else
      response.write "<option value=""" & ifieldvalues(i) & """>" &  ifieldnames(i) & "</option>" & vbcrlf
   end if
  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=""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
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=""selected"">" & ifieldnames(i) & "</option>"
   else
      response.write "<option>" & ifieldnames(i) & "</option>"
   end if
next
%>
</select>
<%
end sub

Sub GenerateSelectMULT_NOVALUES (iFieldnames,fieldcount,currentvalues,currentvaluecount, selectname,firstfield)
' Generates select with no values
%><select multiple size="5" class="txtfielddropdown" name="<%=selectname%>"><%
Dim Currentvalue
Dim j
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)) OR (instr(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=""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 
if databasetype="MYSQL351" then
   ProcessMYSQLServer connection
   exit sub
end if 

'VP-ASP 6.50 - add support for Access 2007
if databasetype="ACCESS2007" then
   ProcessAccess2007 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)
	dim objRec
	sql = "select * from tbluser where fldusername = '" & user & "'"
	Set objRec = con.Execute(SQL)
	if not objrec.eof then
		getaccess = objrec("fldaccess")
	else
		getaccess=""
	end if

	if getaccess = "" then
		if lcase(getsess("Admintype")) = "supplier" then
			sql = "select * from tbluser where fldusername = 'supplier'"
			Set objRec = con.Execute(SQL)
			if not objrec.eof then
				getaccess = objrec("fldaccess")
			else
				getaccess=""
			end if
		end if
	end if

	objRec.Close
	set objrec=nothing
End Function 

Function UserTableAccess(user, table)
     Dim con, accessrec
     ShopOpenDatabase con

	Set accessrec = Server.CreateObject("ADODB.Recordset")	 

	sql = "select tablesallowed from tbluser where fldusername = '" & user & "'"
	Set accessrec = con.Execute(SQL)

	if not accessrec.eof then 
	   if instr("," & accessrec("tablesallowed") & ",", "," & table & ",") > 0 then
			UserTableAccess = True
		else
			UserTableAccess = False
		end if
	else
	   UserTableAccess = False
	end if       
	
	accessrec.Close
	set accessrec=nothing

	ShopCloseDatabase con
End Function


'-------
Sub ShopCheckAdmin (filename)
'	31/1/2006 - functionality no longer supported
'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
'	31/1/2006 - functionality no longer supported
'  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
Shopclosedatabase conn 
If found=true then exit sub
If getconfig("XshowAdmin")<>"Yes" then
     shoperror getlang("LangAdminUnauth") 
end if
end sub

'--- login user activity
Sub LogUser(user,io, dbc)
dim indate, intime
indate=datenormalize(date())
intime = formatdatetime(Time(),vbshorttime)
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

Sub GetDataBaseTables (tables, tablecount,con)
'set array tables with names of tables in database
dim table
dim i
dim tblName
'VP-ASP 6.08 - array lengthened from 250 to 300 for SQL Server 2005 compliance
redim tables(300)
Set table = con.OpenSchema (20)
i=0
While Not table.EOF
  tblName= table("Table_Name")
	'VP-ASP 6.08a - Added TABLE_TYPE check to stop VIEWS from appearing when using SQL SERVER 2005
    If Left(tblName,4) <> "MSys" AND Left(tblName,3) <> "sys" AND Left(tblName,4) <> "RTbl" AND UCASE(table("TABLE_TYPE")) = "TABLE" 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


'VP-ASP 6.00 - Allow tables from split databases to be selected
Sub GetDataBaseTablesPlus (tables, tablecount,con)
'set array tables with names of tables in database
dim table
dim i
dim tblName
redim preserve tables(250)
Set table = con.OpenSchema (20)
i=tablecount
While Not table.EOF
  tblName= table("Table_Name")
	'VP-ASP 6.08a - Added TABLE_TYPE check to stop VIEWS from appearing when using SQL SERVER 2005
    If Left(tblName,4) <> "MSys" AND Left(tblName,3) <> "sys" AND Left(tblName,4) <> "RTbl" AND UCASE(table("TABLE_TYPE")) = "TABLE" 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 

'VP-ASP 6.50 - add support for Access 2007
if databasetype="ACCESS2007" then
   ProcessAccess2007 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")
	dblocation = xdblocation
   dbtype=ucase(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=ucase(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=ucase(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" or Mytable="ORDERTRACKING" or Mytable="SHOPRMA" 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="AFFILIATELOG" 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 MyTable="PRODUCTS" or MyTable="CATEGORIES"  or MyTable="PRODCATEGORIES"  Or MyTable="PRODFEATURES"  Or MyTable="QUANTITYDISCOUNTS" then
    ShopOpenOtherDB connection, getconfig("xproductdb")
    exit sub
end if
' translate
if MyTable="TRANSLATEPRODUCTS" or MyTable="TRANSLATECATEGORIES"  or MyTable="TRANSLATEPRODFEATURES"  then
    ShopOpenOtherDB connection, getconfig("xproductdb")
    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")
 strshipaddress2=rs("oshipaddress2")
 'VP-ASP 6.08
 strcoupon= rs("ocoupon")
 strcoupondiscount=rs("ocoupondiscount")

 'VP-ASP 6.50 - add flag to order to say customer has agreed to terms
 blnlicense = rs("otermsagreed")
 
 else
 strshipname=""
 strShipAddress=""
 strshipaddress2=""
 strShipTown=""
 strShipZip=""
 strShipState=""
 StrShipCountry=""
 strshipCompany=""
 strShipMethodType=""
 strShipCost=""
 'VP-ASP 6.08
 strcoupon= ""
 strcoupondiscount=""
 
 'VP-ASP 6.50 - add flag to order to say customer has agreed to terms
 blnlicense = ""
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
	 if lcase(getsess("CurrentURL")) <> "shoploginforce.asp" then
       responseredirect "shoploginforce.asp"
	  end if
   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") OR (instr(ucase(xdatabasetype), "MYSQL") > 0) 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  
'VP-ASP 6.09 - format for SQL Server
if (ucase(xdatabasetype)="SQLSERVER") then
	'VP-ASP 6.50 - new config option to easily change date delimiter
    if getconfig("xsqlserverdatedelimiter") > "" then
		newdate=yyyy & getconfig("xsqlserverdatedelimiter") & mm & getconfig("xsqlserverdatedelimiter") & dd
	else
		newdate=yyyy & "" & mm & "" & dd
	end if
else
    newdate=yyyy & "-" & mm & "-" & dd
end if
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 ShopFormatCurrencyOLd (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)
setsess "shoperror", msg
responseredirect "shoperror.asp"
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

'***************************************************************
' If there are customer other fields, store in database
'****************************************************************
Sub CustomerGetFieldsRS (rs)
dim words,wordcount,i, customerfieldcount, cfieldname, fieldvalue
redim words(getconfig("xCustomermaxotherfields"))
on error resume next
if getconfig("xCustomerOtherFields")="" then exit sub
Parserecord getconfig("xcustomerOtherFields"), words, wordcount,","
CustomerFieldcount=wordcount
for i = 0 to wordcount-1
   cfieldname="c_" & words(i)
   fieldvalue=rs(words(i))
   if isnull(fieldvalue) then
      fieldvalue=""
   end if
   setsess cfieldname,fieldvalue
next
end sub

Sub CheckValidOrderNumber
If xordernumber="" or xordernumber="0" then
    shoperror "Order number must be entered into shop$config.asp. For free version, it should be STARTER."
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()
'VP-ASP 6.50 - broadened defintion of IF statement to cover cases where xmysql hasn't been set
if ucase(xdatabasetype) = "MYSQL" OR  ucase(xdatabasetype) = "MYSQL351" OR 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
 
 	  'VP-ASP 6.50 - add authorized flag to customer
	  updatecustfield "authorized",""	'6.5
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
        updatecustfield "address2",straddress2      '5.10
        if getconfig("xcustomerotherfields")<>"" then
           customerupdatefields objrs              ' update additional 
        end if   
        objrs.update
        strcustomerid=cstr(objrs("contactid"))   
        closerecordset objrs
        If getconfig("xsqlrecordid")="Yes" then
	   strcustomerid=getlastrecord(dbc, "customers", "contactid")
	end if   
        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, dbc)
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")
' translate
strcname=translatelanguage(dbc, "products", "cname","catalogid", lngCatalogId, strcname)
memcdescription=translatelanguage(dbc, "products", "cdescription","catalogid", lngCatalogId, memcdescription)
'
curcprice = objrs("cprice")
strcimageurl = objrs("cimageurl")
If isnull(strcimageurl) then strcimageurl=""

'VP-ASP 6.50 - added extra image fields
strimageextra1 = objrs("extraimage1")
If isnull(strimageextra1) then strimageextra1=""
strimageextra2 = objrs("extraimage2")
If isnull(strimageextra2) then strimageextra2=""
strimageextra3 = objrs("extraimage3")
If isnull(strimageextra3) then strimageextra3=""
strimageextra4 = objrs("extraimage4")
If isnull(strimageextra4) then strimageextra4=""
strimageextra5 = objrs("extraimage5")
If isnull(strimageextra5) then strimageextra5=""


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
strtaxfree=objrs("taxfree")
strfreeshipping=objrs("freeshipping")
If isnull(strfreeshipping) then strfreeshipping=0
If isnull(strtaxfree) then strtaxfree=0
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
strinventoryproducts=objrs("inventoryproducts")
if isnull(strinventoryproducts) then
   strinventoryproducts=""
end if
  
'VP-ASP 6.50 - allow customers to upload images
strCustomerImage=objrs("CustomerImage")  
  
'      
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")
        strshipaddress2=getsess("shipaddress2")
        straddress2=getsess("address2")
        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
		if strCustomerID  <> "" AND NOT isnull(strCustomerID) then
        SetSess "CustomerID", strCustomerID
		end if
        SetSess "ShipComment", strshipcomment
        SetSess "Custdiscount", strdiscount
        SetSess "GiftCertificate",strgiftcertificate
        SetSess  "BlnMailList",blnMailList
        SetSess  "BlnCookieQuestion",blnCookieQuestion
        SetSess  "Customertype",strcustomertype
        SetSess  "vatnumber",strvatnumber
        SetSess  "hearaboutus",strhearaboutus
        SetSess "ShipAddress2", strShipaddress2
        SetSess "Address2", straddress2
        If getconfig("xCookieLogin")="Yes" and blnCookieQuestion=True then
           SaveCustomerDetailsCookie
        end if
		'VP-ASP 6.09 - this was deleting the current coupon from the session when a customer logs into their account
		''VP-ASP 6.08
		'SetSess "coupon", strcoupon
		'SetSess "coupondiscount", strcoupondiscount
		if getsess("coupon") <> "" then
			'do nothing
		else
		SetSess "coupon", strcoupon
		end if
		if getsess("coupondiscount") <> "" then
			'do nothing
		else
		SetSess "coupondiscount", strcoupondiscount
		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

 'VP-ASP 6.50 - Customer authorization
 if getconfig("xcustomerrequiresauthorization") = "Yes" then
 	 if lcase(rs("authorized")) = "false" then
	 	serror = getlang("langauthdeclined")
	 	rs.close
		set rs=nothing
		ShopClosedatabase myconn
		exit sub
	 elseif isnull(rs("authorized")) then
	 	serror = getlang("langauthnotdone")
	 	rs.close
		set rs=nothing
		ShopClosedatabase myconn
		exit sub
	 end if
 end if

 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")
 straddress2=rs("address2")           ' 5.10
 ' 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=""
        straddress2=""
        strshipaddress2=""
        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",""
		setsess "customername", ""	
		
		''VP-ASP 6.08 Remove Cookie if neccessary
		If getconfig("XCookieLogin")="Yes" then
			response.cookies("CartLogin").expires=date()-1
		end if
		
		'VP-ASP 6.08 Reset firstname and lastname variables so they don't show up in "logged in as"
		setsess "firstname", ""	
		setsess "lastname", ""	
end sub

'**********************************************************
' * add an order to the database
'***********************************************************
' ********* AD ORDER Everything is now available
Sub ShopAddOrder
'VP-ASP 6.50 - broadened defintion of IF statement to cover cases where xmysql hasn't been set
if ucase(xdatabasetype) = "MYSQL" OR  ucase(xdatabasetype) = "MYSQL351" OR 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,getsess("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
	if (lcase(left(trim(getsess("shipmethod")), 4)) = "<br />") OR (lcase(left(trim(getsess("shipmethod")), 1)) = "[") then
		updatefield "oshipmethodtype",getsess("shipmethodtype") & " " & getsess("shipmethod")
	else
		updatefield "oshipmethodtype",getsess("shipmethod")
	end if
'	updatefield "oshipmethodtype",getsess("shipmethodtype")
	updatefield "oshipcost",getsess("smprice")

        updatefield "otax",getsess("taxes")     ' 2.13 fix
		updatefield "opst",getsess("pst")		'6.5
        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 "odualpst",GetSess("dualpst")		'6.50
          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")
        updatefield "oaddress2",getsess("address2")          ' 5.50
        updatefield "oshipaddress2",getsess("shipaddress2")   ' 5.50
        updatefield  "deliverydate",getsess("deliverydate")  '5.50
        updatefield  "deliverytime",getsess("deliverytime")  '5.50  
        updatefield  "producttotal", getsess("OrderProductTotal")  ' 5.50
        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")   
		
		'VP-ASP 6.50 - add flag to order to say customer has agreed to terms
 		updatefield "otermsagreed", getsess("Licenseagreement")
		
		'VP-ASP 6.50 - add selected currency and exchange rate to order record
 		updatefield "ocurrency", getsess("cid")
		updatefield "ocurrencyrate", getsess("Conversionvalue")
 
	rsorder.Update
' Fix for Concurrency 
	oid = rsorder("orderid")
	' some SQL servers dont return orderid properly
	rsorder.Close
	set rsorder=nothing
	If getconfig("xsqlrecordid")="Yes" then
	   oid=getlastrecord(dbc, "orders", "orderid")
	end if   
        SetSess "orderid",oid
        SetSess "oid", oid 
	
' 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)
		
		'VP-ASP 6.50 - allow customer to upload image to order
		rsitem("customerimage") = arrCart(cgraphicname1,i)
		
		If arrcart(cdualprice,i)="" then arrcart(cdualprice,i)=0

		'VP-ASP 6.09 - Better handling for Euro numbers
		If getconfig("xConvertEuropeanNumbers")="Yes" then
			dim tmpunitprice,tmpdualprice
			convertnumber tmpunitprice,arrcart(cunitprice,i)
			convertnumber tmpdualprice,arrcart(cdualprice,i)

			rsitem("unitprice") = tmpunitprice
			rsitem("dualprice") = tmpdualprice
		else
			rsitem("unitprice") = arrcart(cunitprice,i)
			rsitem("dualprice") = arrcart(cdualprice,i)
		end if


                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
	   if Request.QueryString("sppp") <> "" then
	   	 'VP-ASP 6.50 - precautionary security fix
		 if isnumeric(Request.QueryString("sppp")) then
	   		ref = ref & "&sppp=" & Request.QueryString("sppp")
	   end if
	   end if
       ref=AddWebSess(ref)
       ref=ref & "'>" & getlang("LangFirst") & "</a>&nbsp;:&nbsp;"
       Response.Write ref
       ref="<a href='" & scriptname
       ref=ref & "?page=" & (counterstart - 1)
	   if Request.QueryString("sppp") <> "" then
	   	 'VP-ASP 6.50 - precautionary security fix
	   	 if isnumeric(Request.QueryString("sppp")) then
	   		ref = ref & "&sppp=" & Request.QueryString("sppp")
	   end if
	   end if
       ref=AddWebSess(ref)
       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
	   if Request.QueryString("sppp") <> "" then
	   	'VP-ASP 6.50 - precautionary security fix
		if isnumeric(Request.QueryString("sppp")) then
	   		ref = ref & "&sppp=" & Request.QueryString("sppp")
	   end if
	   end if
       ref=AddWebSess(ref)
'      ref=ref & "&pagesize=" & mypagesize
'      ref=ref & "&sqlQuery=" & server.URLencode(mySQL)
       ref=ref & "'>" & pad & counter & "</a>"
       else
       ref="<strong>" & pad & counter & "</strong>"
       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)
	   if Request.QueryString("sppp") <> "" then
	   	'VP-ASP 6.50 - precautionary security fix
		if isnumeric(Request.QueryString("sppp")) then
	   		ref = ref & "&sppp=" & Request.QueryString("sppp")
	   end if
	   end if
       ref=ref & "'>" & getlang("langNext") & "</a>"
       ref=addwebsess(ref)                ' Dec 8 fix
       Response.Write ref

       ref="&nbsp;:&nbsp;<a href='" & scriptname
       ref=ref & "?page=" & maxpages
	   if Request.QueryString("sppp") <> "" then
	   	'VP-ASP 6.50 - precautionary security fix
		if isnumeric(request.QueryString("sppp")) then
	   		ref = ref & "&sppp=" & Request.QueryString("sppp")
	   end if
	   end if
       ref=AddWebSess(ref)
       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 Request.QueryString("sppp") <> "" then
		   	'VP-ASP 6.50 - precautionary security fix
			if isnumeric(Request.QueryString("sppp")) then
	   			ref = ref & "&sppp=" & Request.QueryString("sppp")
	   	   end if 
	   	   end if 
           ref=addwebsess(ref)
           ref=ref & "'>"
           If getconfig("xbuttonpreviouspage")=""  then
              ref=ref & getlang("langpreviouspage")
           else
              ref=ref & "<img 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 Request.QueryString("sppp") <> "" then
		    'VP-ASP 6.50 - precautionary security fix
			if isnumeric(Request.QueryString("sppp")) then
	   			ref = ref & "&sppp=" & Request.QueryString("sppp")
	   	   end if
	   	   end if
           ref=addwebsess(ref)
           ref=ref & "'>"
           If getconfig("xbuttonnextpage")=""  then
              ref=ref & getlang("langnextpage") 
           else
              ref=ref & "<img src=""" & getconfig("Xbuttonnextpage") & """ />"
           end if    
           ref=ref & "</a>&nbsp;&nbsp;"
           Response.Write ref
      end if
      response.write "<br />" & PageNavFontEnd 
      response.write PageNavTableEnd
end sub
'**********************************************************************
' Customer other fields either in order or customer record
'**********************************************************************
Sub CustomerUpdateFields (rs)
dim words,wordcount,i, customerfieldcount, cfieldname, fieldvalue
'on error resume next
if getconfig("xCustomerOtherFields")="" then exit sub
redim words(Getconfig("xCustomermaxotherfields"))
Parserecord getconfig("xcustomerOtherFields"), words, wordcount,","
for i = 0 to wordcount-1
   cfieldname="c_" & words(i)
   fieldvalue=getsess(cfieldname)
'   debugwrite words(i) & "=" & fieldvalue
   If fieldvalue<>"" then 
      rs(words(i))=fieldvalue
    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
'
'******************************************************************
' if there are customer shipping fields, update them into the recordset supplied
'*******************************************************************
Sub ShippingUpdateFields (rs)
dim words,wordcount,i, shippingfieldcount, cfieldname, fieldvalue
on error resume next
if getconfig("xShippingOtherFields")="" then exit sub
redim words(Getconfig("xCustomermaxotherfields"))
Parserecord getconfig("xshippingOtherFields"), words, wordcount,","
for i = 0 to wordcount-1
   cfieldname="s_" & words(i)
   fieldvalue=getsess(cfieldname) 
   If fieldvalue<> "" then 
      rs(words(i))=fieldvalue
    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 class=""submitbtn"" type=""submit"" name=""" & tempname & """ value=""" & buttontext & """ />")
else
    Response.Write("<input type=""image"" class=""imgbtn"" 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 class=""submitbtn"" type=""reset"" name=""" &tempname & """ value=""" & buttontext & """ />")
else
   Response.Write("<img 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
'shoperror Getlang("Langlicensekeymsg")
end sub
'********************************************************************
' See if hacker is trying to run something 
'*****************************************************************
Sub CleanseMessage (msg, rc)
dim badChars,i,lmsg, pos
dim newChars 
badChars = array(";", "--", "@@","=","<script>","\", "/") 
newChars = lcase(msg)
for i = 0 to uBound(badChars) 
   if instr(1,newchars,badchars(i),1)>0 then
       rc=4
       exit sub
   end if    
next
rc=0 
end sub

'***********************************************************************
Sub ShopWriteError (msg)
'xss fix applied 15 January 2006
'dim tmprc
'CleanseMessage msg,tmprc
'if tmprc=4 then msg=""
'end fix
response.write "<br />" & errorfontstart & msg & errorfontend & "<br />"
end sub

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

Sub ShopWriteHeaderPic (msg,url)
response.write "<h2 class=""picheader"" style=""background-image:url(" & url & ")"">" & msg & "</h2>" & vbCrLf
end sub

Sub shopopendatabaseP (connection)
dim dbtype
dim OtherDB
Dim dblocation
If getconfig("xproductdb")="" then
     ShopOpenDatabase connection
else
   Otherdb=getconfig("xproductdb")
   Dblocation=xdblocation
   dbtype=ucase(xdatabasetype)
   OpenOtherDatabase connection,OtherDB,dblocation, dbtype
end if
end sub

Function GetlastRecord(conn,  table, idfield )
dim lrs, lsql, id
lsql="select max("&  idfield & ") from " & table
set lrs=conn.execute(lsql)
id=lrs(0)
closerecordset lrs
getlastrecord=id
end function
'*************************************************************************
' Generate a selext list based on a table
'  conn = open connection
'  table=table name
'  idfield=value for select dispalyfield= display for select
'  displayalt alternate if first field is null
'  current value, selectname=  form field namae
'  sort field 
'  first field normally "select" but if null, no select is added
'******************************************************************************
Sub GenerateTableV (Conn,table,idfield,displayfield,displayalt,currentvalue,selectname, sortfield, firstfield)
dim grs, gsql, fieldvalue, fieldname
gsql="select * from " & table
gsql=gsql &  " order by " & sortfield
set grs=conn.execute(gsql)
if grs.eof then 
   closerecordset grs
   exit sub
end if 
' Generates Select with values
response.write "<select size=""1"" class=""txtfielddropdown"" name=""" & selectname & """>"
If firstfield<>"" then
response.write "<option>" & firstfield & "</option>"
end if
do while not grs.eof   
      fieldvalue=grs(idfield)
      fieldname=grs(displayfield)
      If isnull(fieldname) then
         fieldname=grs(displayalt)
      end if   
      If currentvalue= fieldvalue then
        response.write "<option value=""" & fieldvalue & """ selected=""selected"">" &  Fieldname & "</option>" & vbcrlf
       else
        response.write "<option value=""" & fieldvalue & """>" &  fieldname & "</option>" & vbcrlf
      end if
      grs.movenext
loop
response.write "</select>"
closerecordset grs
end sub
' make sure the databae has been opened once
'
Sub InitializeSystem
dim conn1
If Getconfig("init")<>"" then exit sub
setsess "login","Force"
shopopendatabase conn1
shopclosedatabase conn1
setsess "login",""
end sub

'************************************************************************
' take string in form langxxxx and get real language values
'************************************************************************
Sub Convertlangname  (name)
dim langs(10), wordcount, newname, capprefix,  newword, i
parserecord name, langs, wordcount, " "
newname=""
for i = 0 to wordcount-1
  capprefix=lcase(left(langs(i),4))
  if capprefix="lang" then
	if lcase(left(langs(i), 8)) = "language" then
		newword=langs(i)
	else
	   newword=getlang(langs(i))
	   If instr(newword,"unknown ") then 
		 newword=langs(i)
	   end if  
	  end if
  else
   newword=langs(i)
  end if
  
  If newname<>"" then 
    newname=newname & " "
  end if
  newname=newname & newword
next  
'debugwrite "converting " & name  & " newname=" & newname
name=newname
end sub

'************************************************************************
' create sort links for table column headers
'************************************************************************
sub SortHeader (name,field)
%>
	<script language="javascript" type="text/javascript">
		function sort_<%=field%> ()
		{
			document.forms["main"].sortfield.value="<%=field%>"
			document.forms["main"].sortupdown.value="<%GetSortDirection%>"
			document.forms["main"].submit()
		}
	</script>
	<a style="color:white" href="javascript:sort_<%=field%>()"><%=name%></a>
<%
end sub

Sub GetSortDirection
	select case UCASE(getsess("sortupdown"))
	case "ASC"
		response.write "DESC"
	case "DESC"
		response.write "ASC"
	case else
		response.write "ASC"
	end select
End Sub

Sub CheckAll(table,collectionName)
%><script language="JavaScript" type="text/javascript">
	<!--
	function CheckAll_<%=table%>()
	{
	  for (var i=0;i<document.<%=table%>.elements.length;i++)
	  {
    	var e = document.<%=table%>.elements[i];
  		e.checked = document.<%=table%>.<%=collectionName%>.checked;
	  }
    }
	//-->
</script><%
End Sub

Sub GenerateDisplayHeader(headertext)
	%><table width="100%"  border="0" cellspacing="0" cellpadding="0">
		<tr>
		<td><table width="100%"  border="0" cellpadding="0" cellspacing="0" class="menubdr">
			<tr>
			  <td width="1%" class="vt al"><img src="images/admin/mainsub/main_sub_topleft.gif" width="3" height="24" alt=" " /></td>
			  <td width="98%"><table width="100%"  border="0" cellspacing="0" cellpadding="3">
				  <tr>
					<td class="mainsub_headertext al"><%=headertext%></td>
				  </tr>
			  </table></td>
			  <td width="1%" class="vt ar"><img src="images/admin/mainsub/main_sub_topright.gif" width="3" height="24" alt=" " /></td>
			</tr>
		</table></td>
	  </tr><%
end sub

Sub GenerateDisplayHeaderFlat
	%><table width="100%"  border="0" cellspacing="0" cellpadding="0">
		<tr><%
end sub

Sub GenerateDisplayBodyHeader%>
	<tr>
		<td class="menubdr vt"><table width="100%"  border="0" cellspacing="1" cellpadding="5">
			<tr>
			  <td class="al" style="background-color:#EEEEEE"><table width="100%" cellpadding="2" cellspacing="2" border="0">
				<tr>
				  <td colspan="2">
<% End Sub 

Sub GenerateDisplayBodyFooter%>
					</td>
				</tr>
			  </table></td>
			</tr>
		</table></td>
	  </tr>
	</table>
	<br />
<%End Sub

Sub GetCurrency
 if GetSess("cid") = "" then
  SetSess "cid", getconfig("xcurrencybase")
 end if
 
 if GetSess("cid") <> "" then
 	dim currconn


	'VP-ASP 6.09 - fix for login force error which was stopping you logging into admin first time
	SetSess "Login","Force"
    shopopendatabase currconn
    If GetSess("Login")="Force" then
       SetSess "Login",""
    end if


  'VP-ASP 6.08 - dimmed currencysql and use in place of old "sql". Using "sql" was causing problems as it is used elsewhere
  dim rs,currencysql
  currencysql="select * from currencyvalues where cid= '" & GetSess("cid") & "'"
  'sql="select TOP 1 * from currencyvalues"
  set rs=currconn.execute(currencysql)

  if not rs.eof then
	   SetSess "CID",rs("cid")
      setSess "Fullunitname",rs("fullunitname")
      SetSess "Conversionvalue",rs("conversionvalue")
      SetSess "Newcurrencysymbol",rs("currencysymbol")
 	  SetSess "flagimage",rs("theimage")
   else
 	  SetSess "CID","USD"
      setSess "Fullunitname","American Dollar"
      SetSess "Conversionvalue","1"
      SetSess "Newcurrencysymbol","US$"
  	 SetSess "flagimage","images/currency/usa.jpg"
  end if
    
  closerecordset rs  
  shopclosedatabase currconn
 end if
End Sub

sub showCurrencyFlag
' IF there is no country selected
 IF getSess("CID") = "" THEN
  GetCurrency
 end if
 
' If the selected CID has a flag then show it
 IF getsess("flagimage") <> "" THEN 
 %><img border="0" src="<%=getsess("flagimage")%>"  alt="<%=getsess("Fullunitname")%>" /><%  
 'VP-ASP 6.09 - if xlogonrequired is Yes, flag wasn't displaying
 else
    If getconfig("xlogonrequired")="Yes" and GetSess("Login")<>"" then
	 	GetCurrency
		IF getsess("flagimage") <> "" THEN 
			%><img border="0" src="<%=getsess("flagimage")%>" alt="<%=getsess("Fullunitname")%>" /><%  
		end if
	  end if
	end if
   'VP-ASP 6.09 - end fix
end sub

Sub AddEditor (formname)
	if getconfig("xhtmleditor")= "Yes" then
		'Check user's Browser
		if InStr(Request.ServerVariables("HTTP_USER_AGENT"),"MSIE") then	
			Response.Write "<script language=JavaScript src='editor/scripts/editor.js' type='text/javascript'></script>"
		else
			Response.Write "<script language=JavaScript src='editor/scripts/moz/editor.js' type='text/javascript'></script>"
		end if
	end if
	%><script type='text/javascript' language="javascript">
	function save()
	{
		eval(document.forms.<%=formname%>.saveAction.value)
		document.forms.<%=formname%>.submit();
	}
	</script>
	<input type="hidden" name="saveAction" value="" /><%
End sub

Function addHTMLEditor (fieldname, textdata,formname)%>
<!-- 'Put content from the database to a temporary area -->
<pre id="idTemporary_<%=fieldname%>" name="idTemporary_<%=fieldname%>" style="display:none"><%if textdata > "" then response.write Server.HTMLEncode(textdata)%></pre>
<script language="javascript" type='text/javascript'>
	var oEdit_<%=fieldname%> = new InnovaEditor("oEdit_<%=fieldname%>");
	oEdit_<%=fieldname%>.arrStyle = [["BODY",false,"","font:10px verdana,arial,sans-serif;"]];
	oEdit_<%=fieldname%>.width=550;
	oEdit_<%=fieldname%>.height=200;
	oEdit_<%=fieldname%>.btnSpellCheck=true;
	oEdit_<%=fieldname%>.btnForm=false;
	//VP-ASP 6.09 - added following two parameters to stop editor adding DIVs instead of Ps in IE
	oEdit_<%=fieldname%>.useDIV=false;
	oEdit_<%=fieldname%>.useBR=false;	
	oEdit_<%=fieldname%>.RENDER(document.getElementById("idTemporary_<%=fieldname%>").innerHTML);//load content from the temporary area to the editor
	document.forms.<%=formname%>.saveAction.value = document.forms.<%=formname%>.saveAction.value + "document.forms.<%=formname%>.elements.<%=fieldname%>.value = oEdit_<%=fieldname%>.getHTMLBody();"
</script>
<input type="hidden" name="<%=fieldname%>"  value="" ID=<%=fieldname%>><%
ENd Function

sub getoriginalcurrencysymbol (symbol)
	dim symboldbc, symbolsql, symbolrs
	shopopendatabase symboldbc
	
	symbolsql = "select currencysymbol from currencyvalues where conversionvalue = 1"
	set symbolrs = symboldbc.execute(symbolsql)
	
	if not symbolrs.eof then
		symbol = symbolrs("currencysymbol")
	end if
	
	closerecordset symbolrs	
	shopclosedatabase symboldbc
end sub

'VP-ASP 6.08 - clean invalid characters from strings/6.09b - added new characters to badchars string
function CleanChars(strWords) 
'VP-ASP 6.5.1 - exit function if strwords is nothing
if strwords = "" then
	exit function
end if

if isnull(strwords) then
	exit function
end if

'VP-ASP 6.50 - replace '' with ' in case function has been run twice on same string
strWords = replace(strWords, "''", "'")

dim badChars,i
dim newChars, decodeChars
 
badChars = array("select ", "drop ", "--", "insert into", "delete from","update ","xp_","union ","char(","@@","|","<script",".js","onload","alert(","xss","onmouseover","src=","document.cookie") 
 
newChars = strWords
decodeChars = URLDecode(strWords)
 
for i = 0 to uBound(badChars)
	if instr(1,lcase(newchars),lcase(badchars(i)),1)>0 then
		newchars=""
		cleanchars=newchars
		exit function
	end If
 
	if instr(1,lcase(decodeChars),lcase(badchars(i)),1)>0 then
		decodeChars=""
		cleanchars=decodeChars
		exit function
	end If
next

newchars=replace(newchars,"'","''")
newchars=replace(newchars,"""","&quot;")
newchars=Replace(newchars,"%22","")  'remove any encoded double quotes

cleanChars = newChars 
end function

function URLDecode(sText)
	Dim sDecoded,oRegExpr,oMatchCollection,oMatch
 
	sDecoded = sText
	Set oRegExpr = Server.CreateObject("VBScript.RegExp")
	oRegExpr.Pattern = "%[0-9,A-F]{2}"
	oRegExpr.Global = True
	Set oMatchCollection = oRegExpr.Execute(sText)
	For Each oMatch In oMatchCollection
		sDecoded = Replace(sDecoded,oMatch.value,Chr(CInt("&H" & Right(oMatch.Value,2))))
	Next
	URLDecode = sDecoded
end function

'VP-ASP 6.50 - add a random string to email form to stop bots spamming it
sub getCAPTCHA
%><!--#include file="captcha/captcha_form_inc.asp" --><%
end sub%>