<%Option Explicit%>
[an error occurred while processing this directive]
<%
const pfieldnames=1
const pfieldvalues=2
const pfieldtypes=3
const pfieldcount=4
const ptableflag=5
const ptemplatedisplay=6
const ptemplaterray=7
const ptokenformat=8
const pidfield=9
const pidvalue=10
const ptokens=11
const pdatacurrentrecord=12
const pdata=13
const pdatarecordcount=14
const pdatainmemory=15
const pparseattributes=16
'***********************************************************************
' VP-ASP 5.00 Merge templates with database
' June 11, 2003 Fix readentirefile for emaillist, formatsaving, include
' oitemstemplate HTML
' Fix include in db files Nov 4
' Nov 8, 2003 fix out of stock enter key
' Nov 19,2003 remove private for sun asp 4.0
'**********************************************************************
' Template handling Version 5.00
' "ADD_OITEMS"
' "ADD_PAGEHEADER"
' "ADD_PAGETRAILER"
' "SPECIAL_ORDERBUTTON"
' "SPECIAL_CHECKBOX"
' "ADD_FORMSTART"
' "ADD_FORMEND"
' "ADD_PRODUCTFEATURES"
' "ADD_QUANTITY"
' "ADD_ORDERBUTTON"
' "ADD_CHECKBOX"
' "ADD_TABLE"
' "ADD_TABLEEND"
' "ADD_PRODUCT"
' "ADD_CROSSSELLING"
' "file=filename INCLUDE"
' "field=fieldname INCLUDE
' "ADD_OITEMSTEMPLATE"
'
' Does field substitution from database to a text template
' TemplateDisplay Yes = output to browser
' No put into array
'**********************************************************
'**************************************************************
' filename to be opened
' rc=4 if file cannot be found
' returns fsObj and RecordObj
'*************************************************************
Sub OpenInputFile (filename, fsObj, RecordObj, rc)
on error resume next
Dim whichfile, dbfile
dbfile=left(filename,3)
If lcase(dbfile)="db=" then
OpenInputFiledb filename, fsObj, RecordObj, rc
exit sub
end if
whichfile=server.mappath(filename)
set fsObj = Server.CreateObject("Scripting.FileSystemObject")
set RecordObj= fsObj.OpenTextFile(whichfile, 1, False)
If err.number > 0 then
rc=4
fsObj.close
set fsObj=nothing
else
rc=0
' debugwrite whichfile & " opened ok "
end if
End sub
'
' close a file
Sub CloseFile (fsObj, RecordObj, rc, parsearray)
If parsearray(pdatainmemory)="Yes" then exit sub
set RecordObj = nothing
set fsObj = nothing
rc=0
end sub
'
' reads and entire file template into a memory array
'
' creates and array of converted records
Sub ShopTemplateArray(Filename, RS, Outarray, Outcount)
dim parsearray, fieldnames, fieldvalues, fieldtypes, fieldcount
redim fieldnames(100)
redim fieldvalues(100)
redim fieldtypes(100)
redim parsearray(Pparseattributes)
Dim i
Dim NewRecord
Dim fs,ts
Dim rc
Dim Bypass
Dim tempcount
OpenInputFile Filename, fs, ts, rc
If rc> 0 then
shopwriteError getlang("LangReadFail") & filename
exit sub
end if
GetFieldValues RS, fieldnames, fieldvalues, fieldtypes, fieldcount
dim Temparray
tempcount=ubound(outarray)
redim temparray(tempcount)
outcount=0
SetupParseArray Parsearray, filename, rs, fieldnames, fieldvalues, fieldtypes, fieldcount, fs, ts
ReadEntireFile fs, ts, Tempcount, TempArray, parsearray
CloseFile fs,ts, rc, parsearray
for i = 0 to tempcount - 1
Substitute Temparray(i), NewRecord, Bypass, parsearray, rs
If Bypass=False then
OutArray(outcount)=NewRecord
outcount=outcount+1
end if
next
end sub
'
Sub SetupParseArray (Parsearray, filename, rs, fieldnames, fieldvalues, fieldtypes, fieldcount, fsoobj,recordobj)
dim data, datacount, rc, dbfieldname
redim parsearray(Pparseattributes)
parsearray(pfieldnames)=fieldnames
parsearray(pfieldvalues)=fieldvalues
parsearray(pfieldtypes)=fieldtypes
parsearray(pfieldcount)=fieldcount
parsearray(ptableflag)=""
parsearray(ptemplatedisplay)="No"
parsearray(pidfield)=rs(0).name
parsearray(pidvalue)=rs(0).value
parsearray(pdatarecordcount)=0
parsearray(pdatainmemory)=""
CheckFiledb filename,dbfieldname,rc
If rc=0 then
redim data(500)
ReadEntireFileDB fsoobj, RecordObj, datacount,data,parsearray
parsearray(pdata)=data
parsearray(pdatarecordcount)=datacount
parsearray(pdatacurrentrecord)=0
parsearray(pdatainmemory)="Yes"
end if
end sub
'****************************************************************
' writes each record to browser
'***************************************************************
Sub ShopTemplateWrite(Filename, RS, orc)
Dim i
Dim NewRecord
Dim recordObj, FsObj
dim rc
Dim MyText
dim readcount
Dim Bypass
OpenInputFile Filename, fsObj, RecordObj, rc
If rc> 0 then
shopwriteError getlang("LangReadFail") & filename
orc=4
exit sub
end if
dim parsearray, fieldnames, fieldvalues, fieldtypes, fieldcount
redim fieldnames(150)
redim fieldvalues(150)
redim fieldtypes(150)
redim parsearray(Pparseattributes)
readcount=0
GetFieldValues RS, fieldnames, fieldvalues, fieldtypes, fieldcount
'For i = 0 to fieldcount
' debugwrite fieldnames(i) & "=" & fieldvalues(i)
'next
SetupParseArray Parsearray, filename, rs, fieldnames, fieldvalues, fieldtypes, fieldcount, fsobj, recordobj
Parsearray(pTemplateDisplay)="Yes"
ReadARecord RecordObj, MyText, rc, parsearray
Do while rc=0
Substitute mytext, NewRecord, Bypass, parsearray, rs
If Bypass=False then
Response.write NewRecord & vbcrlf
end if
'debugwrite "old=" & Mytext & " new=" & NewRecord
readcount=readcount+1
ReadARecord RecordObj, MyText, rc, parsearray
' Response.write Server.HTMLEncode(mytext) & " "
Loop
CloseFile fsObj,RecordObj, rc, parsearray
orc=0
end sub
'
Sub ReadEntireFile (fsoobj, RecordObj, readcount, readarray,parsearray)
'on error resume next
dim rc
dim mytext, data, i
If parsearray(pdatainmemory)="Yes" Then
data=parsearray(Pdata)
for i = 0 to parsearray(pdatarecordcount)-1
readarray(i)=data(i)
next
readcount=parsearray(pdatarecordcount)
exit sub
end if
rc=0
readcount=0
ReadARecord RecordObj, MyText, rc, parsearray
'Response.write Server.HTMLEncode(mytext) & " "
'Debugwrite myText
Do while rc=0
readarray(readcount)=mytext
readcount=readcount+1
ReadARecord RecordObj, MyText, rc, parsearray
'Response.write Server.HTMLEncode(mytext) & " "
Loop
end sub
'
Sub ReadARecord (RecordObj, record, rc,parsearray)
If parsearray(Pdatainmemory)="Yes" then
ReadARecordDB RecordObj, record, rc,parsearray
exit sub
end if
if RecordObj.AtEndofStream then
rc=4
exit sub
end if
record = RecordObj.readline
rc=0
End Sub
Function Find_Replace(srchString, FndString, InsertString, strend )
Dim i, LastChar, Next_Pos
Dim CurrentPos, LastPos
Dim tempstring
If strend > 0 Then
LastChar = strend
Else
LastChar = Len(srchString)
End If
tempstring = srchString
Next_Pos = 0
Next_Pos = InStr(Next_Pos + 1, tempstring, FndString)
Do Until (Next_Pos = 0) Or (Next_Pos > LastChar)
tempstring = Left(tempstring, Next_Pos - 1) & InsertString & Right(tempstring, (Len(tempstring) - Len(FndString) - (Next_Pos - 1)))
LastChar = LastChar - Len(FndString) + Len(InsertString)
Next_Pos = 0
Next_Pos = InStr(Next_Pos + 1, tempstring, FndString)
Loop
Find_Replace = tempstring
End Function
'
Sub Substitute (inrecord, workrecord, Bypass, parsearray, parseRS)
' values can be any field in the products table
' or special keywords
' [field]
' [
dim tokenformat
dim tokens(5)
dim tokencount
Dim rc
Dim morefields
Dim dbindex
Dim dbfieldname
Dim dbvalue
Dim dbvalue1
Dim token
Dim Newrecord
Dim fieldfound
Dim pos
Dim endpos
Dim specchar
Dim dbvalue2
Dim firstchar
Dim length
pos = 1
Bypass=False
'Response.write "converting " & Server.HTMLEncode(inrecord) & " "
workrecord = inrecord
morefields = True
fieldfound = False ' used to determine if record is ouput if starts with a $
firstchar = Left(workrecord, 1) ' save first character
Do While morefields = True
pos = InStr(pos, workrecord, "[")
If pos > 0 Then
endpos = InStr(pos, workrecord, "]")
If endpos=0 then
WriteError "Missing ] on field starting at " & Pos
morefields=false
else
length = endpos - pos + 1
tokenformat=""
token = Mid(workrecord, pos, length)
specchar = Mid(token, 2, 1)
dbfieldname = Mid(token, 2, length - 2)
parserecord dbfieldname, tokens, tokencount, " "
if tokencount> 1 then
dbfieldname=tokens(1)
tokenformat=ucase(tokens(0)) ' formatcurrency, formatnumber
'debugwrite "tokenformat=" & tokenformat & " token=" & token
end if
Parsearray(ptokenformat)=tokenformat
Parsearray(ptokens)=tokens
FindField dbfieldname, dbvalue, rc, parsearray, parseRS
If rc > 0 Then Exit Sub
Newrecord = Find_Replace(workrecord, token, dbvalue, 0)
If dbvalue <> "" Then
fieldfound = True ' used to determine if record written
End If
workrecord = Newrecord
end if
Else
morefields = False
End If
Loop
' at this point if record starts with a $ and no fields substituted, do not write it
If firstchar = "$" Then
If fieldfound = False Then
workrecord=""
Bypass=True
Exit Sub
Else
length = Len(workrecord) - 1
Newrecord = Mid(workrecord, 2, length)
workrecord = Newrecord
bypass=False
End If
End If
Bypass=False
End Sub
Sub WriteError (msg)
shopwriteError msg
end sub
'
Sub FindField(fieldname, value, rc, parsearray, parsers)
Dim i
Dim temparea
Dim ucfieldname
Dim Fieldtype
'On error resume next
ucfieldname = UCase(fieldname)
rc = 0
ProcessKeyword ucfieldname, value, rc, parsearray, parseRS
If rc = 0 Then Exit Sub
rc = 0
FindInDatabase ucfieldname, temparea, fieldtype ,rc, parsearray
If rc > 0 then
WriteError "Field " & fieldname & " " & getlang("LangDatabaseFail")
value=""
exit sub
end if
If temparea="" then
value=""
exit sub
end if
' debugwrite fieldname & " type=" & fieldtype & " " & temparea
DoSpecialFormating temparea, Parsearray, parseRS
value = temparea
End Sub
'
Sub FindInDatabase (fieldname, fieldvalue, fieldtype, rc, parsearray)
dim i
dim fieldcount, fieldvalues, fieldtypes, fieldnames
fieldcount=parsearray(pfieldcount)
fieldnames=parsearray(pfieldnames)
fieldvalues=parsearray(pfieldvalues)
fieldtypes=parsearray(pfieldtypes)
'Debugwrite "finding=" & fieldname & " fieldcount=" & fieldcount
for i=0 to fieldcount
' debugwrite "field=" & fieldnames(i) & " value=" & fieldvalues(i)
if fieldname=Fieldnames(i) then
fieldvalue=fieldvalues(i)
fieldtype=fieldtypes(i)
rc=0
'debugwrite fieldname & " found =" & fieldvalue
exit sub
end if
next
rc=4
fieldvalue=""
end sub
'
Sub ProcessKeyword (keyword, value, rc, parsearray,parseRS)
dim tokenformat
tokenformat=parsearray(ptokenformat)
rc=4
Select Case keyword
Case "ADD_OITEMS"
Handle_OITEMS value, parsearray,parseRS
rc=0
Case "ADD_PAGEHEADER"
Handle_PAGEHEADER value, parsearray
rc=0
Case "ADD_PAGETRAILER"
Handle_PageTrailer value, parsearray
rc=0
Case "SPECIAL_ORDERBUTTON"
Handle_SpecialOrderButton value,parsearray,parseRS
rc=0
Case "SPECIAL_CHECKBOX"
Handle_SpecialCheckbox value,parsearray
rc=0
Case "ADD_FORMSTART"
Handle_FormStart "User",parsearray, "shopaddtocart.asp"
rc=0
Case "ADD_FORMEND"
Handle_FormEnd "User",parsearray
rc=0
Case "ADD_PRODUCTFEATURES"
Add_ProductFeatures "User",parsearray,"", parseRS
rc=0
Case "ADD_QUANTITY"
Add_Quantity "User",parsearray
rc=0
Case "ADD_ORDERBUTTON"
Add_Button "User",parsearray
rc=0
Case "ADD_CHECKBOX"
Add_Checkbox "User",parsearray
rc=0
Case "ADD_TABLE"
Add_Table "User",parsearray
rc=0
Case "ADD_TABLEEND"
Add_TableEnd "User",parsearray
rc=0
Case "ADD_PRODUCT"
Add_Product "User",parsearray
rc=0
Case "INCLUDE"
Handle_Include value,parsearray
rc=0
Case "ADD_CROSSSELLING"
Handle_CROSSSELLING value,parsearray, parseRS
rc=0
Case "SUB"
Handle_Product ucase(tokenformat)
rc=0
Case "ADD_OITEMSTEMPLATE"
Handle_OITEMSTEMPLATE value, parsearray, parseRS
rc=0
Case "ADD_OITEMTOTAL"
Handle_OitemTotal value, parsearray, parseRS
rc=0
Case "ADD_OITEMDELIVERY"
Handle_OitemDelivery value, parsearray, parseRS
rc=0
end select
end sub
Sub DoSpecialFormating (value, parsearray, parseRS)
dim tokenformat
tokenformat=parsearray(ptokenformat)
If tokenformat="" then exit sub
dim strprice
Select Case tokenformat
Case "FORMATCURRENCY"
value = shopformatcurrency(value,getconfig("xdecimalpoint"))
Case "DUALPRICE"
ConvertCurrency value, strPrice
value = formatnumber(strprice,getconfig("xdecimalpoint"))
Case "FORMATNUMBER"
value = formatnumber(value,getconfig("xdecimalpoint"))
Case "FORMATDATE"
value = shopdateformat(value,getconfig("xdateformat"))
Case "FORMATCUSTOMERPRICE"
value = HandleCustomerPrice(value, parsearray, parseRS)
Case "URLENCODE"
value = server.urlencode(value)
Case "FORMATSAVING"
value = HandlePriceSaving(value, parsearray,parseRS)
Case "FORMATTIME"
value = formatdatetime(value,vbshorttime)
End Select
end sub
'
Sub Handle_OITEMS (body, parsearray,parseRS)
'*******************************************************
' Template format order items
' expects myconn to be open as open connection
'********************************************************
Dim Isql, deliveryaddress, deliveryarray
dim orderid
Dim rsitems
Dim Dbc, recordid
Dim CR, itemname
recordid=parsearray(pidvalue)
If ucase(Getsess("emailformat"))="HTML" then
CR=" "
else
CR = GetMailCR
end if
'OpenOrderdb dbc
isql="select * from oitems where orderid="
If Getsess("oid")<>"" then
Orderid=GetSess("oid")
else
Orderid=recordid
end if
Body=""
ISql=Isql & Orderid
'debugwrite isql
Set rsitems=myconn.execute(Isql)
Do While Not RSItems.EOF
itemname=rsitems("itemname")
if getconfig("xdeliveryaddress")="Yes" then
deliveryaddress=rsitems("address")
If not isnull(Deliveryaddress) and Deliveryaddress<>"" then
ConvertDeliveryToArray DeliveryArray, Deliveryaddress
GetDeliveryName Itemname, DeliveryArray
end if
end if
If ucase(Getsess("emailformat"))<>"HTML" then
Itemname=RemoveHtmlFileio(itemname, CR)
end if
Body = Body & CR & Itemname & CR
Body = Body & getlang("LangProductQuantity") & ": " & RSItems("numitems") & CR
If getconfig("xDisplayPrices")<>"No" then
Body = Body & getlang("LangProductPrice") & ": " & shopformatcurrency(RSItems("unitprice"),getconfig("xdecimalpoint")) & CR
end if
RSItems.MoveNext
Loop
rsitems.close
Set rsitems=nothing
'Shopclosedatabase dbc
end sub
'
'
'
Sub ShopReadEntireFile(Filename, Outarray, Outcount, parsearray)
Dim i
Dim NewRecord
Dim fs,ts
Dim rc
outcount=0
OpenInputFile Filename, fs, ts, rc
If rc> 0 then
exit sub
end if
ReadEntireFile fs, ts, Outcount, OutArray, parsearray
CloseFile fs,ts, rc, parsearray
rc=0
end sub
Sub Handle_PageHeader (value, parsearray)
dim templatedisplay
templatedisplay=parsearray(ptemplatedisplay)
Value=""
If TemplateDisplay="No" then exit sub
ShopPageHeader
end sub
Sub Handle_PageTrailer (value, parsearray)
dim templatedisplay
templatedisplay=parsearray(ptemplatedisplay)
Value=""
If TemplateDisplay="No" then exit sub
ShopPageTrailer
end sub
'
Sub Handle_SpecialOrderButton (ivalue,parsearray,parseRS)
Handle_FormStart ivalue,parsearray,"shopaddtocart.asp"
Add_Table "", parsearray
prodindex=""
Add_ProductFeatures "",parsearray,"",parseRS
Add_Quantity "",parsearray
Add_Button "",parsearray
Add_Product "",parsearray
Add_TableEnd "",parsearray
Handle_FormEnd "",parsearray
end sub
Sub Add_Product (ivalue, parsearray)
Dim Id, fieldtype, rc
dim fieldname
fieldname="CATALOGID"
id=0
FindInDatabase fieldname, id, fieldtype ,rc, parsearray
If rc > 0 then
WriteError "Field " & fieldname & " " & getlang("LangDatabaseFail")
end if
%>
<%
end sub
'
Sub Add_Table (ivalue, parsearray)
dim tableflag
WriteForm TemplateTable
TableFlag="True"
parsearray(ptableflag)=tableflag
end sub
'
Sub Add_TableEnd (ivalue, parsearray)
dim tableflag
WriteForm ""
Tableflag=""
parsearray(ptableflag)=tableflag
End Sub
'
Sub Handle_SpecialCheckBox (ivalue, parsearray)
Handle_FormStart ivalue, "shopproductselect.asp"
Add_Table "",parsearray
Add_ProductFeatures "",parsearray, "0"
Add_Quantity "", parsearray
Add_CheckBox "",parsearray
Add_Button "",parsearray
Add_TableEnd "",parsearray
Add_ProductIndex "",parsearray
Handle_FormEnd "",parsearray
end sub
Sub Add_ProductIndex (ivalue, parsearray)
WriteForm ""
end sub
'
Sub Add_CheckBox (ivalue, parsearray)
Dim Id, fieldname,fieldtype, rc
fieldname="CATALOGID"
FindInDatabase fieldname, Id, fieldtype ,rc,parsearray
If rc > 0 then
WriteError "Field " & fieldname & " " & getlang("LangDatabaseFail")
end if
If TableFlag<>"" then
Response.write TemplateCheckboxRow & TemplateCheckboxColumn
end if
WriteForm ""
if TableFlag<>"" then
WriteForm TemplateCheckboxColumnEnd
Response.write ""
end if
end sub'
Sub Add_Button (ivalue, parsearray)
dim mytext, mybutton, tableflag
tableflag=parsearray(ptableflag)
dim fieldvalue
dim rc
Dim Id, fieldname,fieldtype
WriteNoStockMessage rc, parsearray
if rc> 0 then
Response.write OutofStockColumn & getlang("LangOutOfStock") & OutofStockColumnEnd
exit sub
end if
fieldname="CATALOGID"
FindInDatabase fieldname, Id, fieldtype ,rc,parsearray
If rc > 0 then
WriteError "Field " & fieldname & " " & getlang("LangDatabaseFail")
else
ID=0
end if
mytext=getconfig("XButtonText")
if mytext="" then
mytext="Order"
end if
mybutton=""
fieldname="BUTTONIMAGE"
fieldvalue=""
FindInDatabase fieldname, fieldvalue, fieldtype ,rc,parsearray
if fieldvalue<>"" then
mybutton= fieldvalue
else
if getconfig("xButtonImage") <>"" then
mybutton=getconfig("xButtonImage")
end if
end if
if tableflag<>"" then
Response.write TemplateButtonRow & TemplateButtonColumn
end if
If myButton="" then
WriteForm ""
else
WriteForm ""
end if
If tableflag<>"" then
response.write ""
end if
end sub
'
Sub Add_Quantity (ivalue, parsearray)
dim strminimumquantity, rc, tableflag, fieldtype
WriteNoStockMessage rc, parsearray
if rc> 0 then exit sub
tableflag=parsearray(ptableflag)
FindInDatabase "MINIMUMQUANTITY", strminimumquantity ,fieldtype, rc,parsearray
If strminimumquantity="" then
strminimumquantity=0
end if
If strMinimumquantity=0 then
If tableflag<>"" then
Response.write TemplateQuantityRow & TemplateQuantityColumn
end if
%>
<%
If tableflag<>"" then
response.write TemplateQuantityColumnEnd & ""
end if
else
GenerateMinimumList strMinimumquantity, parsearray
end if
End sub
'
Sub GetFieldValues (RS, fieldnames, fieldvalues, fieldtypes, fieldcount)
Dim i
dim fldname
i=0
' memo fields must be gotten first
For each fldName in RS.Fields
fieldnames(i) = ucase(fldname.name)
fieldTypes(i) = fldname.type
If Fieldtypes(i)="201" then
fieldvalues(i)=RS(i)
end if
i=i+1
next
fieldcount=i-1
for i=0 to fieldcount
if fieldtypes(i)<>"201" then
fieldvalues(i)=RS(i).value
end if
if isnull(fieldvalues(i)) then
fieldvalues(i)=""
end if
'Debugwrite fieldnames(i) & " " & fieldvalues(i)
next
End Sub
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
'
Sub Add_ProductFeatures (ivalue, parsearray, Index,parseRS)
dim rc, fieldtype, tableflag
prodindex=index
tableflag=parsearray(ptableflag)
FindInDatabase "FEATURES", strfeatures, fieldtype, rc,parsearray
If rc=0 then
FindInDatabase "SELECTLIST", strselectlist, fieldtype, rc,parsearray
FindInDatabase "CATALOGID", lngcatalogid, fieldtype, rc, parsearray
If tableflag<>"" then
WriteForm TemplateFeaturesRow & TemplateFeaturesColumn
end if
FormatProductOptions
if tableflag<>"" then
Writeform TemplateFeaturesColumnEnd & ""
end if
end if
end sub
Sub Handle_FormStart (value, parsearray, action)
Dim Newaction
newaction="shopaddtocart.asp"
If action<>"" then
newaction=action
end if
%>
"
end sub
Sub WriteForm (text)
Response.write text
end sub
Sub Handle_Include (ivalue,parsearray)
'******************************************************
'[filename INCLUDE]
' field=abc INCLUDE]
' abc is field in recordset
'******************************************************
Dim NewRecord, ucfieldname, tokens
Dim recordObj, FsObj
dim rc
Dim MyText
dim readcount
Dim Bypass, filename, pos, fieldtype, filetype
dim values(10),valuecount
readcount=0
tokens=parsearray(ptokens)
filename=tokens(0)
pos=instr(filename,"=")
if pos>0 then
Parserecord filename,values,valuecount,"="
ucfieldname=ucase(values(1))
if ucase(values(0))="FIELD" then
FindInDatabase ucfieldname, filename, fieldtype ,rc,parsearray
If isnull(filename) or filename="" then
exit sub
end if
else
filename=values(1)
end if
end if
'debugwrite "filename=" & filename
' Nov 3 fix
dim savevalue
savevalue=parsearray(Pdatainmemory)
parsearray(Pdatainmemory)="No"
OpenInputFile Filename, fsObj, RecordObj, rc
If rc> 0 then
parsearray(Pdatainmemory)=savevalue
shopwriteError getlang("LangReadFail") & filename
exit sub
else
GetFileType filename,filetype
end if
ReadARecord RecordObj, MyText, rc, parsearray
Do while rc=0
If filetype="TXT" then
' Response.write Server.HTMLEncode(MyText) & " "
ivalue=ivalue & Server.HTMLEncode(MyText) & " "
else
'response.write mytext
ivalue=ivalue & mytext
end if
readcount=readcount+1
ReadARecord RecordObj, MyText, rc, parsearray
Loop
CloseFile fsObj,RecordObj, rc, parsearray
parsearray(Pdatainmemory)=savevalue
end sub
'
Sub GetFileType(filename, filetype)
dim xtype
filetype="TXT"
xtype=ucase(right(filename,3))
Select case xtype
case "TXT"
filetype="TXT"
case "HTM"
filetype="HTM"
case "TML"
filetype="HTM"
end select
end sub
Sub GenerateMinimumList (strminimumquantity,parsearray)
Dim PArray(20),PArrayCount, tableflag
If Getconfig("xproductminimumquantity")="Yes" Then
If tableflag<>"" then
Response.write TemplateQuantityRow & TemplateQuantityColumn
end if
Response.write ""
If tableflag<>"" then
response.write TemplateQuantityColumnEnd & ""
end if
exit sub
end if
dim minamount, amount, multiply
tableflag=parsearray(ptableflag)
minamount=strminimumquantity
parraycount=getconfig("xproductminimumlist")
if parraycount="" then
parraycount=6
end if
parraycount=clng(parraycount)
for i = 1 to parraycount
amount=i*minamount
parray(i)=amount
next
dim i
sSelect = ""
If tableflag<>"" then
Response.write TemplateQuantityRow & TemplateQuantityColumn
end if
Response.write sSelect
If tableflag<>"" then
response.write TemplateQuantityColumnEnd & ""
end if
end sub
Function RemovehtmlFileio(itemname, CR)
dim workrecord, firstchar, morefields, pos, endpos, length
dim token
workrecord=replace(itemname," ",CR)
'If mailremovehtml<>"Yes" then
' Removehtml=workrecord
' exit function
'end if
pos=1
morefields = True
Do While morefields = True
pos=1
pos = InStr(pos, workrecord, "<")
If pos > 0 Then
endpos = InStr(pos, workrecord, ">")
If endpos=0 then
morefields=false
else
length = endpos - pos + 1
token = Mid(workrecord, pos, length)
workrecord=replace(workrecord,token,"")
end if
else
morefields=false
end if
loop
RemovehtmlFileio=workrecord
end function
'************************************************************
' add cross seelling links
'*************************************************************
Sub Handle_CrossSelling (ivalue, parsearray,parseRS)
dim lngcstock
dim strCrossProductIDs,strsql, rs, strmessage, strcdescurl,strurl
dim fieldtype,rc
FindInDatabase "CROSSSELLING", strcrossProductids, fieldtype, rc, parsearray
If rc>0 then exit sub
if strCrossProductids="" then exit sub
strsql="select * from products where catalogid in (" & strcrossproductids & ")"
strsql=strsql & " and hide=0"
if getconfig("xstocklow")<>"" then
lngcstock= clng(getconfig("xstocklow"))
strsql = strsql & " and cstock> " & lngcstock
end if
set rs=dbc.execute(strsql)
While Not rs.EOF
strCDescURL=rs("cdescurl")
If isnull(Strcdescurl) then
strCDescURL=getconfig("xCrossLinkURL")
end if
if ucase(strcDESCURL)="SHOPEXD.ASP" then
strurl="shopexd.asp?id=" & rs("catalogid")
else
strurl="shopquery.asp?catalogid=" & rs("catalogid")
end if
strMessage=strMessage & " " & Rs("cname") & ""
RS.MoveNext
WEND
RS.Close
set RS=Nothing
strMessage=" " & getlang("LangCrossSellingMessage") & strMessage
Response.write strmessage
end sub
Sub WriteNoStockMessage (rc, parsearray)
dim lngcstock,id,fieldtype,rc1, fieldname
rc=0
if getconfig("xOutOfStockLimit")="" then exit sub
fieldname="CSTOCK"
FindInDatabase fieldname, lngcstock, fieldtype ,rc1, parsearray
'debugwrite "LNGCSTOCK=" & lngcstock & " " & rc1
if isnull(lngcstock) then exit sub
If lngcstock="" then exit sub
if clng(lngcstock)>clng(getconfig("xOutOfStocklImit")) then exit sub
rc=4
end sub
Sub ShopMergetemplate (dbtable, template, catalogid, idfield)
dim tempdatabase, tmprs, rc
EditOpenDatabase dbc, tempdatabase, dbtable
'on error resume next
if isnumeric (catalogid) then
Sql="select * from " & dbtable
If idfield<>"" then
sql=sql & " where " & idfield & "=" & catalogid
end if
else
sql="select * from " & dbtable
If idfield<>"" then
sql=sql & " where " & idfield & "='" & catalogid & "'"
end if
end if
Set tmpRS=dbc.execute(sql)
If tmpRS.eof then
If catalogid<>"" then
Serror = SError & getlang("LangReadFail") & "-" & getlang("LangEditTableName") & "=" & dbtable
else
Serror = SError & getlang("LangReadFail") & " " & getlang("langedittablename") & "=" & dbtable
end if
end if
If serror="" then
ShopTemplateWrite template, tmpRS, rc
end if
CloseRecordset tmpRS
Shopclosedatabase dbc
end sub
'
Function HandleCustomerPrice (iprice, parsearray,parseRS)
dim discount, categoryid, ioprice, newprice
dim fieldtype, rc
newprice=iprice
FindInDatabase "CATALOGID", catalogid, fieldtype ,rc, parsearray
FindInDatabase "CCATEGORY", categoryid, fieldtype ,rc, parsearray
ShopCustomerPrices ParseRS, catalogid, categoryid, iprice, newprice,discount
HandleCustomerprice=shopformatcurrency(newprice,getconfig("xdecimalpoint"))
end function
Function HandlePriceSAving (iprice, parsearray,parseRS)
dim discount, categoryid, ioprice, newprice
dim strretailprice, saving
dim fieldtype, rc
newprice=iprice
FindInDatabase "RETAILPRICE", strretailprice, fieldtype ,rc, parsearray
If strretailprice="" then exit function
If strretailprice=0 then exit function
FindInDatabase "CATALOGID", catalogid, fieldtype ,rc, parsearray
FindInDatabase "CCATEGORY", categoryid, fieldtype ,rc, parsearray
ShopCustomerPrices ParseRS, catalogid, categoryid, iprice, newprice,discount
saving=strretailprice-newprice
HandlePriceSaving=shopformatcurrency(saving,getconfig("xdecimalpoint"))
end function
Sub Handle_OITEMSTEMPLATE (body, parsearray,parseRS)
'*******************************************************
' Template format order items
' expects myconn to be open as open connection
'********************************************************
dim filename, outarray(10), outcount, suffix, emailformat
filename=Getconfig("xoitemstemplate")
Dim Isql,orderid, rsitems
Dim recordid
Dim CR, itemname, i
recordid=parsearray(pidvalue)
Suffix=right(filename,3)
If ucase("suffix")<>"TXT" then
setsess "emailformat","HTML"
end if
If ucase(Getsess("emailformat"))="HTML" then
CR=""
else
CR = GetMailCR
end if
'OpenOrderdb dbc
isql="select * from oitems where orderid="
If Getsess("oid")<>"" then
Orderid=GetSess("oid")
else
Orderid=recordid
end if
Body=""
ISql=Isql & Orderid
'debugwrite isql
Set rsitems=myconn.execute(Isql)
If rsitems.eof then
closerecordset rsitems
exit sub
end if
do while not rsitems.eof
ShopTemplateArray Filename, RSITEMS, Outarray, Outcount
for i = 0 to outcount-1
itemname=outarray(i)
If ucase(Getsess("emailformat"))<>"HTML" then
Itemname=RemoveHtmlFileio(itemname, CR)
end if
Body = Body & CR & Itemname
next
rsitems.movenext
loop
closerecordset rsitems
end sub
Sub Handle_OitemTotal(value,parsearray,parseRS)
dim quantity, unitprice, rc, fieldtype, price, total
FindInDatabase "NUMITEMS", quantity, fieldtype ,rc, parsearray
FindInDatabase "UNITPRICE", unitprice, fieldtype ,rc, parsearray
Total=quantity*unitprice
value=shopformatcurrency(total,getconfig("xdecimalpoint"))
end sub
Sub Handle_OitemDelivery(value,parsearray,parseRS)
dim rc, fieldtype, price, total, itemname
dim CR
dim deliveryaddress, deliveryarray
If ucase(Getsess("emailformat"))="HTML" then
CR=" "
else
CR = GetMailCR
end if
if getconfig("xdeliveryaddress")="Yes" then
FindInDatabase "ADDRESS", deliveryaddress, fieldtype ,rc, parsearray
If not isnull(Deliveryaddress) and Deliveryaddress<>"" then
ConvertDeliveryToArray DeliveryArray, Deliveryaddress
GetDeliveryName Itemname, DeliveryArray
If ucase(Getsess("emailformat"))<>"HTML" then
Itemname=RemoveHtmlFileio(itemname, CR)
end if
value=itemname
end if
end if
end sub
'****************************************************************
' see if template is in database. If it is open the recordset
' put whole template into fsobj
'******************************************************************
Sub OpenInputFiledb (filename, fsObj, RecordObj, rc)
dim dbprefix, dbfilename, conn
shopopendatabase conn
dbprefix=left(filename,3)
if lcase(dbprefix)="db=" then
dbfilename=right(filename,len(filename)-3)
else
dbfilename=filename
end if
dim sql
sql="select * from templates where templatename='" & dbfilename & "'"
If getconfig("xdebug")="Yes" then
debugwrite sql
end if
set recordobj=conn.execute(sql)
If not recordobj.eof then
rc=0
fsobj=recordobj("template")
else
rc=4
end if
closerecordset recordobj
shopclosedatabase conn
recordobj=""
If rc=0 then
recordobj="db"
end if
end sub
Sub ReadEntireFileDB (fsoobj, RecordObj, readcount, readarray,parsearray)
dim data, delimiter, i
delimiter="~"
readcount=0
data=replace(fsoobj,vbcrlf,delimiter)
parserecord data, readarray, readcount,delimiter
'debugwrite "Recordcount=" & readcount
'for i = 0 to readcount
' debugwrite readarray(i)
'next
end sub
'***********************************************************************
' Record are already in memory in the parse arary
'************************************************************************
Sub ReadARecordDB (RecordObj, record, rc,parsearray)
dim data, currentrecord, recordcount
currentrecord=parsearray(pdatacurrentrecord)
recordcount=parsearray(pdatarecordcount)
data=parsearray(pdata)
If currentrecord=recordcount then
rc=4
exit sub
end if
record=data(currentrecord)
currentrecord=currentrecord+1
parsearray(pdatacurrentrecord)=currentrecord
rc=0
end sub
Sub CheckfileDB(filename,fieldname,rc)
dim dbprefix
dbprefix=left(filename,3)
if lcase(dbprefix)="db=" then
fieldname=right(filename,len(filename)-3)
rc=0
else
fieldname=""
rc=4
end if
end sub
%>
<%
'***************************************************
' Version 5.00 June 12, 2003 enhnaced quantity features
' This routine is used to obtain features and display them
' Analyze features customer has selected
' add a product to the internal shopping Cart
' This routine consist of three separate parts
' CartAddItem used to add aproduct to the shopping cart
' FormatProductOptions Generates the form fields for product features
' GetProductFeatures Process the user selected features
'*************************************************
'
dim prodindex
dim FeatureMultiSelection
dim Sfeature
Dim NameInCart
Dim fcount
Dim sSelect
Dim PrevOptionNum
Dim tempOption
dim maxOptionNum
dim strDualPrice
Dim ProductPrice
Dim DiscountPrice
Dim OriginalPrice
Dim userselectedstring
dim fprefix
Dim sxRequiredList, sXRequiredValue
dim lngFeatureid
dim featurevaluecount
Dim ProductSku, Featureconn
Dim requiredlist
dim userselectedcount, userselected(100)
dim featurequantity, strfeaturedefault
'***************************************************
' add a product to the cart. Common routine
' handles feature analysis and discounts'
'*****************************************************
Sub CartAddItem(id, rc)
' Return 0 if added, 4 if product does not exist
' Get from datbase and add to instorage array
dim scartitem
Dim arrCart
Dim TotalOptionPrice
dim TotaloptionDualPrice
Dim Optionname
Dim CartFields, ArtFieldcount
ProductPrice=CurCPrice ' original price
featurequantity=""
If GetSess ("NewProductPrice")<>"" then
ProductPrice=GetSess("NewProductPrice") ' created by features
If GetSess ("NewProductQuantity")<>"" then
quantity=GetSess("NewProductquantity") ' created by features
end if
end if
DiscountPrice=ProductPrice ' DiscountPrice
OriginalPrice=ProductPrice
LocateInArray id,rc ' see if we already have some
if rc=0 then ' already found
exit sub
end if
' old method, now uses cartfields in shop$colors
' NameinCart=strcName & " " & memCDescription ' description
arrCart = GetSessA("CartArray")
scartItem = GetSess("CartCount")
scartitem=scartitem+1
If scartItem > clng(getconfig("xMaxCartitems") )then
ResponseRedirect "shoperror.asp?msg=" & Server.URLEncode ( getlang("Langerror02"))
End If
arrCart(cProductid,scartItem) = lngcatalogID
arrCart(cCategory,scartItem) = lngCcategory
arrCart(cProductCode,scartItem) = strccode
arrCart(cGroupDiscount,scartItem) = strgroupfordiscount
AddCartOptions TotalOptionPrice, TotalOptionDualPrice
If featurequantity<>"" then
quantity=featurequantity
end if
CorrectMinimumquantity quantity,strminimumquantity
Correctmaximumquantity quantity,strmaximumquantity
CheckStockLevel quantity, lngcatalogid
CalculateUserPrice ProductPrice, Quantity, DiscountPrice, arrCart, scartitem
ProductPrice=DiscountPrice
AddUserText ' text within product record
If not IsNull(StrSpecialOffer) then
NameIncart = NameInCart & " " & strSpecialOffer
end if
arrCart(cProductname,scartItem) = NameInCart
arrCart(cQuantity,scartItem) = quantity
arrCart(cOriginalPrice,scartItem) = OriginalPrice + TotalOptionPrice
arrCart(cUnitPrice,scartItem) = ProductPrice + TotaloptionPrice
arrCart(cProductFeatures,scartItem) = UserSelectedString
if getconfig("XdualPrice")="Yes" then
If strcdualprice="" then
Convertcurrency ProductPrice, strDualPrice
else
strdualprice=strcdualprice ' get from product
end if
ConvertCurrency TotaloptionPrice, TotalOptionDualPrice
arrCart(cDualPrice,scartItem) = strDualprice + TotaloptionDualPrice
else
arrCart(cDualPrice,scartItem) = 0
end if
arrCart(cMinimumQuantity,scartItem) = strminimumquantity
arrCart(cSupplierid,scartItem) = strsupplierid
arrCart(cDelivery,scartItem) = ""
if isnull(lngcstock) then
lngcstock=""
end if
If GetSess ("NewProductPrice")="" then
arrCart(cmaximumQuantity,scartItem) = strmaximumquantity
else
If GetSess ("NewProductQuantity")<>"" then
quantity=GetSess("NewProductquantity") ' created by features
AdjustQuantityPrices arrcart, scartitem, quantity, productprice, totaloptionprice
setsess "NewProductquantity",""
end if
end if
arrCart(cStockLevel,scartItem) = lngcstock
arrCart(cProductimage,scartItem) = strcimageurl
arrCart(cProductweight,scartItem) = strweight
arrCart(cProductassociated,scartItem) = ""
arrCart(cProductmininame,scartItem) = strcname
SetSess "CartCount",scartitem
SetSessA "CartArray",arrCart
rc=0
end sub
'
' If we find it then just add new quantity
Sub LocateInArray(id,rc)
Dim i
dim lngid
dim scartitem
dim arrcart
lngid=clng(id)
rc=4 ' not found
' Anything with features needs to be added new
If strFeatures<>"" then
CheckFeaturesStockLevel quantity, lngcatalogid
exit sub
end if
If memUserText<>"" then
exit sub
end if
scartItem = GetSess("CartCount")
If scartitem=0 then
exit sub
end if
arrCart = GetSessA("CartArray")
dim newquantity
For i = 1 to scartItem
If lngid = arrCart(cProductid,i) then
newquantity=arrCart(cQuantity,i)+clng(quantity)
validatequantity newquantity
CheckStockLevel newquantity, lngcatalogid
arrCart(cQuantity,i) = newquantity
CalculateUserPrice arrCart(cOriginalPrice,i), arrCart(cQuantity,i), DiscountPrice, arrcart, i
arrCart(cUnitPrice,i)=DiscountPrice
rc=0
SetSessA "CartArray",arrCart
exit sub
end if
Next
End Sub
Sub GenerateMinQuantityList (i, quantity)
dim lngquantity
Dim PArray(100),PArrayCount
dim amount, sSelect, j
lngquantity=clng(quantity)
' Fix Oct 19
parraycount=getconfig("xproductminimumlist")
if parraycount="" then
parraycount=6
end if
parraycount=clng(parraycount)
for j = 1 to parraycount
amount=j*minamount
parray(j)=amount
next
sSelect = sSelect & ""
%>
<%=sSelect%>
<%
end sub
'
Sub CheckStockLevel (quantity, catalogid)
dim lquantity, lstock
If getconfig("XCheckStockLevel")<>"Yes" then exit sub
lquantity=clng(quantity)
if isnull(lngcstock) then exit sub
lstock=clng(lngcstock)
If lquantity>lstock then
shoperror getlang("LangStockLevel") & "(" & lngcstock & ") - " & strcname
end if
end sub
Sub AddCartOptions (totalOptionPrice, TotalOptionDualPrice)
'**********************************************************************
' Features have been stored in the feature array
' feature count has the number of features stored
'**********************************************************************
Dim sPrice
Dim OPrice
Dim optionName
Dim sFeature, featureother
Dim MaxFeatures, msg, tempselect
TotalOptionPrice=0
TotaloptionDualPrice=0
sFeature=""
Productsku=""
sPrice=""
Maxfeatures=Featurecount
If maxfeatures=0 then exit sub
'Debugwrite "featurecount=" & featurecount
sFeature=""
dim percent, percentamount
for i = 0 to MaxFeatures-1
strfeaturename= Featurearray(cfeaturevalue,i)
oprice=Featurearray(cfeatureprice,i)
featureother=Featurearray(cfeatureother,i)
strfeaturecaption=Featurearray(cfeaturecaption,i)
strfeaturepercent=Featurearray(cfeaturepercent,i)
percentamount=0
If strfeaturepercent<>"" then
If strfeaturepercent<1 then
strfeaturepercent=strfeaturepercent*100
end if
percentamount=(strfeaturepercent/100*curcprice)
Percent = strfeaturepercent & "%"
end if
if sFeature="" Then
If curcprice>0 then
sFeature= FeatureBasePriceFont & getlang("LangproductBasePrice") & shopformatcurrency(curCPrice,getconfig("xdecimalpoint")) & FeatureBasePriceEnd
sFeature= sFeature & " " & FeatureHeaderFont & getlang("LangProductFeaturesOptions") & FeatureHeaderFontEnd
end if
end if
sFeature=sfeature & " " & CartFeatureCaption & strfeaturecaption & CartFeatureCaptionEnd & " "
sFeature= sFeature & FeatureFont & strfeaturename & FeatureFontEnd
if getconfig("xcurrencysymbol")<>"" and oprice<>"" then
oprice=replace(oprice,getconfig("xcurrencysymbol"),"")
end if
If oprice="" then
oprice=0
end if
if OPrice<>0 then
TotalOptionPrice=TotaloptionPrice+OPrice
If Oprice > 0 then
sFeature = SFeature & FeaturePriceFont & getlang("LangFeatureAdd") & shopformatcurrency(OPrice,getconfig("xdecimalpoint")) & FeaturePriceEnd
else
sFeature = SFeature & FeaturePriceFont & getlang("LangFeatureSubtract") & shopformatcurrency(OPrice,getconfig("xdecimalpoint")) & FeaturePriceEnd
end if
end if
if percentamount<>0 then
TotalOptionPrice=TotaloptionPrice+percentamount
If percentamount > 0 then
sFeature = SFeature & FeaturePriceFont & getlang("LangFeatureAdd") & percent & FeaturePriceEnd
else
sFeature = SFeature & FeaturePriceFont & getlang("LangFeatureSubtract") & percent & FeaturePriceEnd
end if
end if
Createsku productsku, featureother
next
NameInCart=NameIncart & sFeature
If Productsku<>"" and getconfig("xgeneratesku")="Yes" then
NameinCart= "Sku: " & Productsku & " " & NameinCart
end if
end sub
'
'
'
Sub CreateSku (productsku, strfeatureother)
If isnull(strfeatureOther) then exit sub
If strfeatureother="" then exit sub
If ProductSku="" then
Productsku=strccode
end if
Productsku=Productsku & "-" & strfeatureother
end sub
'
'
Sub VerifyRequired (msg)
dim requiredlist
msg=""
' SxRequirelistvalue ha the list of features that are required
Requiredlist=split(sxrequiredvalue,",")
For i = 0 to ubound(Requiredlist)
FindSelected RequiredList(i), msg
next
end sub
'
Sub FindSelected (feature, msg)
' Find this required feature in the list of selected features
dim j, tempmsg, fsql, featurecaption, rs
'debugwrite "selectedcount=" & userselectedcount
If featurecount>0 then
for j =0 to featurecount
' Debugwrite "feature=" & feature & "selected=" & Userselected(j)
if clng(feature)=clng(Featurearray(cfeaturenum,j)) then
exit sub
end if
next
end if
Fsql="select * from prodfeatures where featurenum=" & feature
set rs=Featureconn.execute(fsql)
featurecaption=rs("featurecaption")
rs.close
set rs=nothing
tempmsg= getlang("LangFeatureMissing") & strcname & " - " & featurecaption & " "
msg=msg & tempmsg
end sub
'
Sub CheckFeaturesStockLevel (quantity, catalogid)
dim lstock
dim totquantity
Dim i
dim lngid
dim scartitem
dim arrcart
If getconfig("XCheckStockLevel")<>"Yes" then exit sub
if isnull(lngcstock) then exit sub
lstock=clng(lngcstock)
lngid=clng(catalogid)
totquantity=clng(quantity)
scartItem = GetSess("CartCount")
If scartitem=0 then
exit sub
end if
arrCart = GetSessA("CartArray")
For i = 1 to scartItem
If lngid = arrCart(cProductid,i) then
Totquantity=arrCart(cQuantity,i) +totquantity
end if
Next
If totquantity>lstock then
shoperror getlang("LangStockLevel") & "(" & lngcstock & ") - " & strcname
end if
end sub
'
'*********************************************************
' make sure quantity matches minimum
'********************************************************
Sub CorrectminimumQuantity (quantity, minquantity)
dim tempmin
if getconfig("xproductminimumquantity")<>"Yes" then exit sub
if not isnumeric (minquantity) then exit sub
tempmin=clng(minquantity)
if tempmin= 0 then exit sub
if clng(quantity)>= tempmin then exit sub
quantity=tempmin
end sub
'
'*********************************************************
' make sure quantity matches minimum
'********************************************************
Sub CorrectMaximumQuantity (quantity, maxquantity)
dim tempmin
if getconfig("xproductmaximumquantity")<>"Yes" then exit sub
if not isnumeric (maxquantity) then exit sub
tempmin=clng(maxquantity)
if tempmin= 0 then exit sub
if clng(quantity)<= tempmin then exit sub
quantity=tempmin
end sub
Sub AdjustQuantityPrices (arrcart, scartitem, quantity, productprice, totaloptionprice)
dim price
arrCart(cmaximumQuantity,scartItem) = quantity
arrCart(cQuantity,scartItem) = quantity
Price=GetSess("NewProductPrice")
price=price/quantity
arrCart(cOriginalPrice,scartItem) = price
arrCart(cUnitPrice,scartItem) = price
price=arrCart(cDualPrice,scartItem)
price=price/quantity
arrCart(cDualPrice,scartItem)=price
setsess "NewProductQuantity",""
arrCart(cotherinfo,scartItem)="static"
end sub
%>
<%
Sub ConvertCurrency (iamount, oamount)
' VP-ASP 5.0 Feb 4, 2003
'
' Convert currency
dim ydualconversionrate
ydualconversionrate=getconfig("xdualconversionrate")
if not isnumeric(ydualconversionrate) then
exit sub
end if
if ydualconversionrate<>"" then
ydualconversionrate=cdbl(ydualconversionrate)
oamount=iamount*ydualconversionrate
else
oamount=iamount
end if
end sub
%>
<%
'*************************************************************************
' Version 5.00 VP-ASP
' Customer based pricing
' after a price has been read from the database
' This routine is called by GetProduct to determine whether
' there is a specific price for acustomer
' Feb 4, 2003
'***************************************************************************
dim custdbc
const customerpricetable="customerprices"
Sub ShopCustomerPrices (objrs, catalogid, categoryid, ioprice, newprice,discount)
'****************************************************************
' obtain the correct price for the customer
' first lookup specific product
' if not found lookup specific category
'*****************************************************************
dim customerid, rc
if getconfig("xcustomerPrices")<>"Yes" then exit sub
if getconfig("Xcustomerpricefields")<>"" then
CustomerPricesinRecord objrs, catalogid, categoryid, ioprice, newprice,discount
exit sub
end if
ShopOpenDatabase custdbc
discount=0
newprice=ioprice
customerid=GetSess("Customerid")
if customerid="" then
exit sub
end if
LookupCustomerProduct catalogid, customerid, newprice,discount, rc
if rc= 0 then
exit sub
end if
LookupCustomerCategory categoryid, customerid, NewPrice,discount, rc
if rc=0 then
exit sub
end if
LookupCustomerOnly customerid, NewPrice,discount, rc
if rc=0 then
exit sub
end if
shopclosedatabase custdbc
end sub
'
Sub LookupCustomerProduct (catalogid, customerid, Price,discount, rc)
dim lookupsql, lookuprs, oldprice, newprice
Dim Discountamount,DiscountPercent
lookupsql="select * from " & customerpricetable
lookupsql = lookupsql & " where customerid=" & customerid
lookupsql = lookupsql & " and catalogid=" & catalogid
Set lookuprs=custdbc.execute(lookupsql)
if lookuprs.eof then
rc=4
lookuprs.close
set lookuprs=nothing
exit sub
end if
debugwrite "found"
debugwrite lookupsql
discountamount=lookuprs("discountamount")
discountpercent=lookuprs("discountpercent")
ApplyCustomerPrice Price, discountamount, discountPercent, discount
lookuprs.close
set lookuprs=nothing
shopclosedatabase custdbc
end sub
Sub ApplyCustomerprice (price, amount, percent, discount)
dim newprice
If not isnull(amount) and amount>0 then
Newprice=price-amount
discount=newprice/price
discount=1-discount
discount=discount*100
price=newprice
debugwrite "price=" & price & " discount=" & discount
exit sub
end if
If not isnull(percent) then
discount=percent
if percent>1 then
percent=percent/100
end if
Newprice=price- (Price*percent)
NewPrice=formatnumber(NewPrice,getconfig("xdecimalpoint"))
price=Newprice
end if
'debugwrite "newprice=" & newprice
end sub
Sub LookupCustomerCategory (categoryid, customerid, Price,discount, rc)
Dim Discountamount,DiscountPercent
dim lookupsql, lookuprs, discountper, newprice
lookupsql="select * from " & customerpricetable
lookupsql = lookupsql & " where customerid=" & customerid
lookupsql = lookupsql & " and categoryid=" & categoryid
set lookuprs=custdbc.execute(lookupsql)
if lookuprs.eof then
rc=4
lookuprs.close
set lookuprs=nothing
exit sub
end if
Discountamount=lookuprs("Discountamount")
DiscountPercent=lookuprs("Discountpercent")
if getconfig("xdebug")="Yes" then
debugwrite "Price=" & price & " discountPercent=" & discountpercent
end if
ApplycustomerPrice Price, discountamount, discountPercent, discount
lookuprs.close
set lookuprs=nothing
shopclosedatabase custdbc
rc=0
end sub
Sub LookupCustomerOnly (customerid, Price,discount, rc)
Dim Discountamount,DiscountPercent
dim lookupsql, lookuprs, discountper, newprice
lookupsql="select * from " & customerpricetable
lookupsql = lookupsql & " where customerid=" & customerid
lookupsql = lookupsql & " and categoryid=0 and catalogid=0"
Set lookuprs=custdbc.execute(lookupsql)
if lookuprs.eof then
rc=4
lookuprs.close
set lookuprs=nothing
exit sub
end if
Discountamount=lookuprs("Discountamount")
DiscountPercent=lookuprs("Discountpercent")
if getconfig("xdebug")="Yes" then
debugwrite "Price=" & price & " discountPercent=" & discountpercent
end if
ApplycustomerPrice Price, discountamount, discountPercent, discount
lookuprs.close
set lookuprs=nothing
shopclosedatabase custdbc
rc=0
end sub
'****************************************************************
' contact id field determines which customer price field to use
' objrs is the current record in products table
' Uses xcustomerpricefields
' xcustomepricesindexes
'*****************************************************************
sub CustomerPricesinRecord (objrs, catalogid, categoryid, ioprice, newprice,discount)
dim fields(50),fieldcount, customerpricefields, customerpricetypes
dim types(50), typecount, customertype, ctype, pricefield
dim donumerictest, i, xdebug
on error goto 0
xdebug=getconfig("xdebug")
if getsess("customertype")="" then exit sub
customerpricefields=getconfig("Xcustomerpricefields")
customerpricetypes=getconfig("Xcustomerpricetypes")
customertype=getsess("customertype")
If isnumeric(customertype) then
customertype=clng(customertype)
donumerictest=true
else
donumerictest=false
customertype=ucase(customertype)
end if
If xdebug="Yes" then
debugwrite "Pricefields=" & customerpricefields
debugwrite "Types=" & customerpricetypes
debugwrite "Customer type=" & getsess("customertype")
end if
if customerpricefields="" then exit sub
if customerpricetypes="" then exit sub
parserecord customerpricefields, fields,fieldcount,","
parserecord customerpricetypes, types,typecount,","
for i = 0 to typecount-1
ctype=types(i)
if donumerictest=true then
if isnumeric(ctype) then
ctype=clng(ctype)
'debugwrite "comparing2 ctype=" & ctype & " against " & customertype
if customertype=ctype then
pricefield=fields(i)
SetCustomerPricefield objrs, pricefield, newprice
exit sub
else
' debugwrite "did not match " & ctype & " ct=" & customertype
end if
end if
else
' debugwrite "comparing2 ctype=" & ctype & " against " & customertype
if customertype=ucase(ctype) then
pricefield=fields(i)
SetCustomerPricefield objrs, pricefield, newprice
exit sub
end if
end if
next
end sub
Sub SetCustomerpricefield (objrs, fieldname, price)
dim tprice
tprice=objrs(fieldname)
if isnull(tprice) then exit sub
price=tprice
end sub
%>
<%
'**********************************************************************************
' Version 5.00 Automatic Extended Description
' shopexd.asp?id=xx
' xx = catalogid
' The template to be used is is xproducttemplate of a specific template for
' the product in the database
' July 11, 2003
'*********************************************************************************
Dim CatalogId
dim ccode
Dim tmpRS
Dim template
dim dbc
dim rc
setSess "CurrentURL","shopexd.asp"
Catalogid=request("id")
if not isnumeric(catalogid) then
catalogid=""
end if
ccode=request("ccode")
If ccode<>"" then
ccode=replace(ccode,"'","")
end if
if catalogId="" and ccode="" then
catalogid=getsess("shopexdid")
if catalogid="" then
Serror=getlang("LangNoCatalogId")
HandleError
end if
end if
Setsess "shopexdid",catalogid
ShopOpendatabase dbc
OpenRecordSet tmpRS
GetTemplate
If Template="" then
Serror=getlang("LangExdNoTemplate")
HandleError
end if
ShopTemplateWrite template, tmpRS, rc
tmpRS.close
set tmpRS=nothing
Shopclosedatabase dbc
'Finished
Sub HandleError
on error resume next
tmpRS.close
set tmpRS=nothing
Shopclosedatabase dbc
Response.Redirect "shoperror.asp?msg=" & Server.URLEncode (sError)
end sub
'
Sub OpenRecordSet (RS)
If catalogid<>"" then
Sql="select * from products where catalogid=" & catalogid
else
sql="select * from products where ccode='" & ccode & "'"
end if
Set rs=dbc.execute(sql)
If rs.eof then
Serror = SError & getlang("LangReadFail") & " " & catalogid
HandleError
end if
end sub
'
Sub GetTemplate
on error resume next
dim suffix
Template=""
template=request("template")
if template<>"" then
suffix=right(template,3)
if lcase(suffix)="htm" then
exit sub
end if
end if
Template=getconfig("xProductTemplate")
If isNull(tmpRS("template")) then
Template=getconfig("xProductTemplate")
else
template=tmprs("template")
end if
End sub
%>