<%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
' May 25, 2003
'
'**********************************************************************
' 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
'
Private 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, parsearary)
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 exit sub
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
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
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
OpenInputFile Filename, fsObj, RecordObj, rc
If rc> 0 then
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
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
Response.write OutofStockColumn & getlang("LangOutOfStock") & OutofStockColumnEnd
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 "RETAILEPRICE", 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
filename=Getconfig("xoitemstemplate")
Dim Isql,orderid, rsitems
Dim recordid
Dim CR, itemname, i
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)
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
%>
<%
'****************************************************************
' VP-ASP Display shop categories
' displays a list of categories from Shopping Database
' Version 5.00 Jan 3, 2003
' Support images for each category and multiple columns per listing
' Now allows product displays or subcategory displays
' Sub hide for categories
' add template handling
'****************************************************************
dim colcount, ycatmaxcolumns, totalcolumncount
Dim strcatImage
dim lngcatid
'dim strcategory
dim strcathide
Dim Mylink, dbc
dim highercategoryid
dim strcatmemo, strcatextra
'**********************************************************
' main program flow
'************************************************************
setsess "currenturl","shopdisplaycategories.asp"
ShopOpenDatabase dbc
CheckDatabaseOpen dbc
ycatmaxcolumns=clng(getconfig("xcatmaxcolumns"))
ShopCategories
ShopCloseDatabase dbc
'
'*********************************************************
' Write header
' format categories
' Write trailer
'*********************************************************
Sub ShopCategories
highercategoryid=request("id")
if highercategoryid="" then
highercategoryid=0
end if
ShopPageHeader ' Page header for shop
CategoryHeader ' category header on this page
Showcategories ' format categories on this page
ShopPageTrailer ' shop page trailer
end sub
'***************************************************************
' Format all categories
' generate SQL
' loop through all categories found
'***********************************************************'
' Show Categories
Sub ShowCategories()
Dim rs
colcount=0
totalcolumncount=0
SQL="Select * from categories "
sql = Sql & " where highercategoryid=" & highercategoryid
if getconfig("xproductmatch")="Yes" then
sql=sql & " and productmatch='" & xproductmatch & "'"
end if
if getconfig("xproductmatchcustomer")="Yes" then
if GetSess("CustomerProductGroup")<>"" then
sql=sql & " and customermatch='" & getsess("customerProductgroup") & "'"
end if
end if
Handle_selectcategoriesbylanguage
sql=sql & " order by " & Getconfig("xsortcategories")
OpenRecordSet dbc, rs, sql
While Not rs.EOF
strcatmemo=rs("catmemo")
strcatextra=rs("catextra")
lngcatid=rs("categoryid")
strcategory=rs("catdescription")
strsubcategory=rs("hassubcategory")
strcatimage=rs("catimage") ' image
strcathide=rs("cathide") ' hide field
if isnull(strcathide) then
strcathide="No"
end if
if isNull(strcatimage) then
strcatimage=""
end if
if isNULL(strsubcategory) then
strsubcategory=""
end if
If isnull(strcategory) then
strcathide="Yes"
end if
If isnull(strcatextra) then
strcatextra=""
end if
If isnull(strcatmemo) then
strcatmemo=""
end if
If getconfig("xcategoryusetemplate")= "Yes" then
FormatCategoryTemplate lngcatid, strcategory,rs
else
FormatCategory lngcatid, strcategory
End if
rs.MoveNext
Wend
if colcount> 0 then
FillRemainingcolumns
end if
response.write ""
CloseRecordSet rs
end sub
'*************************************
' Used only if template formatting is used
'*************************************************
Sub FormatCategoryTemplate(lngcatid, strcategory, objrs)
dim template, rc
template=getconfig("xcategorydisplaytemplate")
If Template="" then
Serror=getlang("LangExdNoTemplate")
shoperror serror
end if
if ucase(strcathide)="YES" then
exit sub
end if
if colcount=0 then
Response.write CatRow
end if
response.write CatColumn
ShopTemplateWrite template, objRs, rc
Response.write CatColumnEnd
colcount=colcount+1
totalcolumncount=totalcolumncount+1
if colcount>= yCatMaxColumns then
response.write ""
colcount=0
end if
End Sub
'**************************************************
' writes out header
'******************************************************
Sub CategoryHeader
If highercategoryid<>0 then
Generatecategorylinks
else
response.write " "
response.write catHeader & getlang("LangCat01") & catheaderend & "
"
end if
response.write CatTable
end sub
'*************************************************************
' formats 1 category record
'************************************************************
Sub FormatCategory (id, name)
if ucase(strcathide)="YES" then
exit sub
end if
if colcount=0 then
Response.write CatRow
end if
response.write CatColumn
if strSubcategory ="" then
response.write "" & name & ""
else
Response.write "" & name & "..."
If getconfig("Xcategoryproductsonly")="No" then
Response.write " "
response.write "" & getlang("LangProductProduct") & ""
Response.write " " & getlang("langSubcategories") & ""
end if
end if
If strCatImage<> "" then
AddImage id, Name
end if
If strcatmemo<>"" then
FormatCatmemo
end if
Response.write CatColumnEnd
colcount=colcount+1
totalcolumncount=totalcolumncount+1
if colcount>= yCatMaxColumns then
response.write ""
colcount=0
end if
end sub
'***************************************************************
' if category has image, format it
'***************************************************************
Sub AddImage(id, iname)
dim mylink
dim linkname
linkname=Server.URLEncode(Iname)
if strSubcategory ="" then
%>
<%
else
%>
<%
end if
end sub
Sub FillRemainingColumns
If totalcolumncount< ycatmaxcolumns then
response.write ""
exit sub
end if
Do While Colcount "
colcount=colcount+1
loop
response.write ""
end sub
'
Sub GenerateCategoryLinks
dim highercatid, cats(10),catids(10), i
dim cathead, more, catsql, rs
dim id,name
highercatid=highercategoryid
cathead=""
More=True
i=0
Do while more=True
catsql="select * from categories where categoryid=" & highercatid
Set rs=dbc.execute(catsql)
If not rs.eof then
highercatid=rs("highercategoryid")
name=rs("catdescription")
id=rs("categoryid")
mylink="" & name & ""
cats(i)=mylink
i=i+1
if highercatid=0 then
more=false
end if
else
more=false
end if
Closerecordset rs
loop
For i = 0 to i-1
If cathead="" Then
cathead = cats(i)
else
cathead= cats(i) & subcatseparator & cathead
end if
next
response.write subcatheader & cathead & subcatheaderend
end sub
Sub Handle_Product (isub)
select case isub
Case "FORMATIMAGE"
If strCatImage<> "" then
AddImage lngcatid, strcategory
end if
Case "FORMATHYPERLINKS"
GenerateCatLink lngcatid,strcategory
case else
debugwrite "Unknown sub"
end select
end sub
Sub GenerateCatLink(id,name)
if strSubcategory ="" then
response.write "" & name & ""
else
Response.write "" & name & "..."
If getconfig("Xcategoryproductsonly")="No" then
Response.write " "
response.write "" & getlang("LangProductProduct") & ""
Response.write " " & getlang("langSubcategories") & ""
end if
end if
End Sub
sub Formatcatmemo
If getconfig("xcategorydisplaytext")="Yes" then
if strcatmemo<>"" then
response.write catmemostart & strcatmemo & catmemoend
end if
end if
end sub
sub Handle_selectcategoriesbylanguage
If getconfig("xselectproductsbylanguage")="Yes" and getsess("language")<>"" then
sql=sql & " and (catlanguage='" & getsess("language") & "'"
sql=sql & " or catlanguage is null)"
end if
end sub
%>