<%
'************************************************
' Shop subroutines VP-ASP 6.50
' Numerous product, date category subroutines
' Nov 11,2005 Fix top sellers Mysql
' nOV 12, 2005 Fix langip
' Dec 31, 2005 Fix fieldvalue mismatch Issue 729
' Dec 31 2005 Update navigateshowcategoriesstyled
' Sep 12 2006 Added code to CheckDeliveryFree to
' always have free shipping for gift certificate
'*************************************************
Sub SetupProductFieldsXXX (ProdFields, ProdHeaders)
dim tempfields,swords(20),swordscount,i
tempfields=getconfig("xproductfields")
parserecord tempfields,swords,swordscount,","
redim prodFields(swordscount-1)
for i = 0 to swordscount-1
prodfields(i)=swords(i)
next
end sub
'
Sub SetupSearchFields (SearchFields)
dim tempfields,swords(20),swordscount,i
IF strSearchFields = "" THEN
tempfields=getconfig("xsearchfields")
ELSE
tempfields = strSearchFields
END IF
parserecord tempfields,swords,swordscount,","
redim SearchFields(swordscount-1)
for i = 0 to swordscount-1
searchfields(i)=swords(i)
next
end sub
'
'*******************************************************************
' This routine puts fields into the cart
'****************************************************************
' Shopcartformat Formats field in cart
Sub GetNameInCart (Rsitem, dbc)
dim tempfields,cartfields(20),fieldcount,i, fieldvalue
dim tempcatalogid
tempfields=getconfig("xcartfields")
if tempfields = "" then
shoperror getlang("langcommonno") & " " & getlang("langsearchfields") & " to " & getlang("langeditdisplay")
end if
parserecord tempfields,cartfields,fieldcount,","
nameincart=""
tempcatalogid=rsitem("catalogid")
for i = 0 to fieldcount-1
If cartfields(i)="cdescription" then
fieldvalue= memCDescription
fieldvalue=translatelanguage(dbc, "products", "cdescription","catalogid", tempcatalogid, fieldvalue)
else
fieldvalue=rsitem(cartfields(i))
If lcase(cartfields(i))="cname" then
fieldvalue=translatelanguage(dbc, "products", "cname","catalogid", tempcatalogid, fieldvalue)
end if
end if
if not isnull(fieldvalue) then
if nameincart<>"" then
nameincart=nameincart & " "
end if
nameincart=nameincart & fieldvalue
end if
next
end sub
Function GetMailCR
'GetMailCR= Chr(13)
GetMailCR= Chr(13) & chr(10)
end function
'
'***************************************************************
' Used throughout the code to create a text form box
'***************************************************************
Sub CreateCustRow (caption, fieldname, fieldvalue, required)
Dim aster
If required="Yes" then
aster="* "
else
aster=" "
end if
Response.write tablerow & "
"
Response.write aster & Caption & "
"
Response.write tablecolumn
%><%
Response.write tablecolumnend & tableRowend
end sub
'
Sub CreateCustRowP (caption, fieldname, fieldvalue, required)
Dim aster
If required="Yes" then
aster="* "
else
aster=" "
end if
Response.write tablerow & "
"
Response.write aster & Caption & "
"
Response.write tablecolumn
%>
<%
Response.write tablecolumnend & tableRowend
end sub
'******************************************************************
' used in the admin section to create a text form box
'*******************************************************************
Sub FormatEditRow (caption,fieldname,fieldvalue)
if fieldvalue > "" then
fieldvalue = Replace(fieldvalue,"""",""")
end if
dim capdisplay
capdisplay=caption
if capdisplay="" then
capdisplay=fieldname
end if
Response.Write TableRow
Response.write TableColumn & capdisplay & TableColumnEnd
Response.write TableColumn & "" & vbcrlf
Response.write tableColumnEnd
Response.write TableRowEnd
end sub
Sub FormatEditRowBoolean (caption,fieldname,fieldvalue, Yesnos, Yesnocount)',helpfile)
dim capdisplay
capdisplay=caption
if capdisplay="" then
capdisplay=fieldname
end if
Response.Write TableRow
Response.write "
" & capdisplay & "
"
Response.write "
"
GenerateselectNV YesNos,fieldvalue,fieldname,yesnocount, ""
Response.write tableColumnEnd
If helpfile<>"" and getconfig("xproducthelp")="Yes" then
' FormatEditHelp fieldname, helpfile
end if
Response.write TableRowEnd
end sub
'******************************************************************
' used in admin section to create a static equivalent of a text box
'*******************************************************************
Sub FormatEditRowStatic (caption,fieldname,fieldvalue)
dim capdisplay, yfont
capdisplay=caption
if capdisplay="" then
capdisplay=fieldname
end if
yfont=xTableRowFont
Response.Write TableRow
Response.write TableColumn & capdisplay & TableColumnEnd
Response.write TableColumn & Yfont & fieldvalue & xTableRowFontEnd
Response.write tableColumnEnd
Response.write TableRowEnd
end sub
'***********************************************************
' used in admin area to ceate a multirow text area
'************************************************************
Sub FormatEditRowTextArea (caption,fieldname,fieldvalue)
dim capdisplay, rows
capdisplay=caption
if capdisplay="" then
capdisplay=fieldname
end if
rows=3
Response.Write TableRow
Response.write TableColumn & capdisplay & TableColumnEnd
response.write "
" & vbcrlf
Response.write tableColumnEnd
Response.write TableRowEnd
end sub
'***********************************************************************
' if doing help for products and categories
'************************************************************************
Sub FormatEditHelpHeader
if getconfig("xproducthelp")<>"Yes" then exit sub
%>
<%
end sub
'********************************************************************
' write help column for products and categories
'*******************************************************************
Sub FormatEditHelp(fieldname, helpfile)
if getconfig("xproducthelp")<>"Yes" then exit sub
response.write "
"
%>
<%
response.write tablecolumnend
end sub
'
'****************************************************************
' creates category drop down list
'***************************************************************
Sub NavigateShowCategories()
If getconfig("Xnavigatecategories")="No" then exit sub
If getconfig("xlogonrequired")="Yes" then
If getsess("login")="" then
exit sub
end if
end if
If getconfig("init")="" then exit sub
dim cid, name,catSQL,i
dim strcategory, catcount, categories,maxcategories
Dim catdbc,catrs, hassubcategory,mylink
'catcount=getsess("catcount")
If catcount="" then catcount=0
'VP-ASP 6.50 - advanced session handling
'If xusefilesession="Yes" then
If xsavesession="Yes" then
catcount=0
end if
If catcount=0 then
catcount=0
maxcategories=getconfig("xmaxcategories")
redim categories(maxcategories)
ShopOpenDatabaseP catdbc
If not catdbc.state=adStateOpen then
shopclosedatabase catdbc
exit sub
end if
catSQL="Select * from categories where highercategoryid=0 and cathide is null "
'VP-ASP 6.09 - add product matching to this sub
if getconfig("xproductmatch")="Yes" then
'VP-ASP 6.50 - changed below to show matching categories and categories with no association when productmatching is on
' catsql=catsql & " and productmatch='" & xproductmatch & "'"
catsql=catsql & " and (productmatch='" & xproductmatch & "' or productmatch is null)"
end if
if getconfig("xproductmatchcustomer")="Yes" then
if GetSess("CustomerProductGroup")<>"" then
catsql=catsql & " and (customermatch like '%" & getsess("customerProductgroup") & "%'"
catsql=catsql & " or customermatch is null)"
else
catsql=catsql & " and customermatch is null"
end if
end if
If getconfig("xselectproductsbylanguage")="Yes" and getsess("language")<>"" then
catsql=catsql & " and (catlanguage='" & getsess("language") & "'"
catsql=catsql & " or catlanguage is null)"
end if
'VP-ASP 6.08 - Order by config option rather than hardcoded
if getconfig("xsortcategories") <> "" then
catSQL=catsql & " order by " & getconfig("xsortcategories")
else
catSQL=catsql & " order by catdescription"
end if
' catSQL=catsql & " order by catdescription"
set catrs=catdbc.execute(catsql)
While Not catrs.EOF and catcount" & name & ""
else
mylink="" & name & "..."
end if
categories(catcount)=mylink
catcount=catcount+1
catrs.MoveNext
Wend
setsessa "categories",categories
setsess "catcount",catcount
catrs.Close
set catrs=nothing
ShopCloseDatabase catdbc
end if
'
catcount=getsess("catcount")
categories=getsessa("categories")
response.write NavCatTable
for i = 0 to catcount-1
mylink=categories(i)
response.write NavCatRow & NavCatColumn
response.write mylink
response.write NavCatColumnend
next
response.write ""
exit sub
end sub
'Displays stylesheet driven menu
Sub NavigateShowCategoriesStyled()
If getconfig("Xnavigatecategories")="No" then exit sub
If getconfig("xlogonrequired")="Yes" then
If getsess("login")="" then
exit sub
end if
end if
If getconfig("init")="" then exit sub
dim cid, name,catSQL,i
dim strcategory, catcount, categories,maxcategories
Dim catdbc,catrs, hassubcategory,mylink
'catcount=getsess("catcount")
If catcount="" then catcount=0
'VP-ASP 6.50 - advanced session handling
'If xusefilesession="Yes" then
if xsavesession = "Yes" then
catcount=0
end if
If catcount=0 then
catcount=0
maxcategories=getconfig("xmaxcategories")
redim categories(maxcategories)
ShopOpenDatabaseP catdbc
If not catdbc.state=adStateOpen then
shopclosedatabase catdbc
exit sub
end if
catSQL="Select * from categories where highercategoryid=0 and cathide is null "
if getconfig("xproductmatch")="Yes" then
'VP-ASP 6.50 - enhanced productmatching
catsql=catsql & " and "
Generateproductmatchsqlsubscat catsql
' catsql=catsql & " and productmatch='" & xproductmatch & "'"
end if
if getconfig("xproductmatchcustomer")="Yes" then
if GetSess("CustomerProductGroup")<>"" then
catsql=catsql & " and (customermatch like '%" & getsess("customerProductgroup") & "%'"
catsql=catsql & " or customermatch is null)"
else
catsql=catsql & " and customermatch is null"
end if
end if
If getconfig("xselectproductsbylanguage")="Yes" and getsess("language")<>"" then
catsql=catsql & " and (catlanguage='" & getsess("language") & "'"
catsql=catsql & " or catlanguage is null)"
end if
'VP-ASP 6.08 - Order by config option rather than hardcoded
catSQL=catsql & " order by " & getconfig("xsortcategories")
' catSQL=catsql & " order by catdescription"
set catrs=catdbc.execute(catsql)
While Not catrs.EOF and catcount" & name & ""
else
mylink="" & name & "..."
end if
categories(catcount)=mylink
catcount=catcount+1
catrs.MoveNext
Wend
setsessa "categories",categories
setsess "catcount",catcount
catrs.Close
set catrs=nothing
ShopCloseDatabase catdbc
end if
'
catcount=getsess("catcount")
categories=getsessa("categories")
'VP-ASP 6.50 - modified to use list instead of table
%>
<%
for i = 0 to catcount-1
mylink=categories(i)
%>
<%
response.write mylink
%>
<%
next
%>
<%
exit sub
end sub
' MiniCart
'*******************************************************************
' Create mini cart
' If passed value "SHORT" it creates a small mini cart
'*******************************************************************
Sub NavigateShowMiniCart (itype)
' VP-ASP 5.00
dim showtype
showtype=ucase(itype)
Dim scartItem, arrCart, displayprice
dim dualtotal, dualsubtotal, dualprice
dim totalquantity, totalproductquantity
Dim i, CartFields, total, subtotal, name, quantity, price
scartItem = GetSess("CartCount")
arrCart = GetSessA("CartArray")
If scartitem="" then exit sub
if scartitem=0 then exit sub
dim hideprice
hideprice = false
if getconfig("xdisplayprices") <> "Yes" then
hideprice = true
end if
if getconfig("xpriceloggedinonly") = "Yes" then
if Getsess ("login") = "" then
hideprice = true
end if
end if
If getconfig("Xnavigateminicart")="No" then exit sub
response.write "
"
If showtype<>"SHORT" Then
Response.write Minitable
response.write MiniTitleRow
response.write MiniNameTitleColumn & minititlefont & getlang("langProductDescription") & "" & Minifontend
response.write MiniPriceColumn & minititlefont & getlang("langProductQuantity") & "" & Minifontend
If hideprice <> true then
response.write MiniPriceColumn & minititlefont & getlang("langProductPrice") & "" & Minifontend
response.write MiniPriceColumn & minititlefont & getlang("langProductTotal") & "" & Minifontend
If getconfig("xdualprice")="Yes" then
response.write MiniPriceColumn & minititlefont & getlang("langDualPrice") & "" & Minifontend
response.write MiniPriceColumn & minititlefont & getlang("langDualTotal") & "" & Minifontend
end if
end if
Response.write ""
end if
if getconfig("xLCID")<>"" then
Session.LCID=getconfig("xLCID") ' set user supplied LCID
end if
total = 0
totalquantity=scartitem
totalproductquantity=0
For i = 1 to scartItem
Quantity =arrCart(cQuantity,i)
Price=arrCart(cUnitPrice,i)
dualprice=arrCart(cdualPrice,i)
If dualprice="" then dualprice=0
Name=arrCart(cProductMiniName,i)
if name="" then
Name=arrCart(cProductName,i)
end if
dim nameconn2
shopopendatabaseP nameconn2
name=translatelanguage(nameconn2, "products", "cname","catalogid", arrCart(cProductid,i), name)
shopclosedatabase nameconn2
subtotal=quantity*price
dualsubtotal=quantity*dualprice
Total=total+subtotal
dualtotal=dualtotal+dualsubtotal
totalproductquantity=totalproductquantity+quantity
If showtype<>"SHORT" Then
Price=shopformatcurrency(price,getconfig("xdecimalpoint"))
response.write minirow
Response.write MiniNameColumn & Minifont & name & minicolumnend
Response.write MiniPricecolumn & MiniFont & quantity & minicolumnend
If hideprice <> true then
Response.write MiniPriceColumn & MiniFont & Price & minicolumnend
Response.write MiniPriceColumn & Minifont & shopformatcurrency(subtotal,getconfig("xdecimalpoint")) & minicolumnend
If getconfig("xdualprice")="Yes" then
dualPrice=formatnumber(dualprice,getconfig("xdecimalpoint"))
Response.write MiniPriceColumn & MiniFont & dualPrice & minicolumnend
Response.write MiniPriceColumn & Minifont & ShopFormatDualCurrency(dualsubtotal,getconfig("xdecimalpoint")) & minicolumnend
end if
end if
response.write ""
end if
next
If showtype="SHORT" Then
Response.write MinitableShort
response.write MinititleRow
response.write MiniPriceColumn & minifont & getlang("langProductQuantity") & Minifontend
If hideprice <> True then
response.write MiniPriceColumn & minifont & getlang("langProductPrice") & "" & Minifontend
end if
response.write ""
response.write minirow
Response.write MinipriceColumn & Minifont & totalproductquantity & Minicolumnend
If hideprice <> true then
Response.write MinipriceColumn & minifont & shopformatcurrency(total,getconfig("xdecimalpoint")) & Minicolumnend
end if
else
If hideprice <> true then
response.write "
"
response.write MiniPricecolumn & minifont & minifontend
response.write MiniPriceColumn & minifont & shopformatcurrency(total,getconfig("xdecimalpoint")) & minifontend
If getconfig("xdualprice")="Yes" then
response.write "
" & MiniPriceColumn & minifont & ShopFormatDualCurrency(dualtotal,getconfig("xdecimalpoint")) & minifontend
end if
end if
end if
response.write "
"
If Getconfig("xcurrencylink")="Yes" Then
dim url, cprice
cprice=shopformatnumber(total,getconfig("xdecimalpoint"))
url="http://www.x-rates.com/cgi-bin/cgicalc.cgi?value=" & cprice & "&base=" & Getconfig("Xcurrencybase")
Response.write " " & "Convert " & Getconfig("xcurrencybase") & " " & cprice & ""
end if
end sub
Sub NavigateShowMiniCartRight (itype)
'****************************
' VP-ASP 6.00
' formats the minicart in the right menu
'
' Added functionality to remove extended display when "short" option is passed
' VPASP - Michael - 11 Jan 2006
'****************************
dim showtype, sqlmininav
showtype=ucase(itype)
Dim scartItem, arrCart, displayprice
dim dualtotal, dualsubtotal, dualprice
dim totalquantity, totalproductquantity
Dim i, CartFields, total, subtotal, name, quantity, price, URLCart
scartItem = GetSess("CartCount")
arrCart = GetSessA("CartArray")
If (scartitem="") OR (scartitem=0) then
response.write getlang("langcartisempty")
exit sub
end if
dim hideprice
hideprice = false
if getconfig("xdisplayprices") <> "Yes" then
hideprice = true
end if
if getconfig("xpriceloggedinonly") = "Yes" then
if Getsess ("login") = "" then
hideprice = true
end if
end if
If getconfig("Xnavigateminicart")="No" then exit sub
If showtype<>"SHORT" Then
If hideprice <> true then
If getconfig("xdualprice")="Yes" then
end if
end if
end if
if getconfig("xLCID")<>"" then
Session.LCID=getconfig("xLCID") ' set user supplied LCID
end if
total = 0
totalquantity=scartitem
totalproductquantity=0
For i = 1 to scartItem
Quantity =arrCart(cQuantity,i)
Price=arrCart(cUnitPrice,i)
dualprice=arrCart(cdualPrice,i)
If dualprice="" then dualprice=0
name=arrcart(cproductname,i)
URLCart=arrCart(cproductid,i)
If len(name)>50 then
name=mid(name,1,50)
end if
dim nameconn
'VP-ASP 6.09 - changed below database open to shopopendatabaseP to allow for split databases
shopopendatabaseP nameconn
'VP-ASP 6.08 - Show Parent Name before product name, if applicable
'VP-ASP 6.08a - Change variable SQL to SQLMININAV
sqlmininav = "select catalogid, highercatalogid, cname from products where catalogid = " & URLCart
dim namers, cname, pname
set namers = nameconn.execute(sqlmininav)
if not namers.eof then
if namers("highercatalogid") > "" then
cname = namers("cname")
cname = translatelanguage(nameconn, "products", "cname","catalogid", namers("catalogid"), cname)
'VP-ASP 6.08a - Change variable SQL to SQLMININAV
sqlmininav = "select catalogid, cname from products where catalogid = " & namers("highercatalogid")
set namers = nameconn.execute(sqlmininav)
if not namers.eof then
pname = namers("cname")
pname = translatelanguage(nameconn, "products", "cname","catalogid", namers("catalogid"), pname)
name= pname & " - " & cname
else
name=translatelanguage(nameconn, "products", "cname","catalogid", arrCart(cProductid,i), name)
end if
else
name=translatelanguage(nameconn, "products", "cname","catalogid", arrCart(cProductid,i), name)
end if
else
name=translatelanguage(nameconn, "products", "cname","catalogid", arrCart(cProductid,i), name)
end if
closerecordset nameconn
shopclosedatabase nameconn
subtotal=quantity*price
dualsubtotal=quantity*dualprice
total=total+subtotal
dualtotal=dualtotal+dualsubtotal
totalproductquantity=totalproductquantity+quantity
Price=shopformatcurrency(price,getconfig("xdecimalpoint"))
If showtype<>"SHORT" Then
%>
<%=quantity%>
<%
dim exdsql, exdrs, exdconn
ShopOpenDatabaseP exdconn
exdsql = "select cdescurl from products where catalogid = " & arrCart(cProductid,i)
set exdrs = exdconn.execute(exdsql)
if not exdrs.eof then
'VP-ASP 6.50 - go to shopquery.asp if it is set in the config
if ucase(getconfig("xCrossLinkurl"))="SHOPEXD.ASP" then
strDescurl= "shopexd.asp?id="
else
strDescurl= "shopquery.asp?catalogid="
end if
end if
CloseRecordset exdrs
ShopCloseDatabase exdconn
if isnull(strDescurl) then
strdescurl=""
end if
If strDescURL<>"" then
If getconfig("xAddCatalogid")="Yes" then
'VP-ASP 6.08a - added bc=no to stop breadcrumb appearing in page
'VP-ASP 6.50 - go to correct URL
'VP-ASP 6.50 - advanced session handling
strDescURL=strDescURL & arrCart(cProductid,i) & "&bc=no" & addwebsesslink
end if
else
If getconfig("xGenerateShopexdLink")="Yes" then
strdescurl="shopexd.asp"
'VP-ASP 6.08a - added bc=no to stop breadcrumb appearing in page
'VP-ASP 6.50 - go to correct URL
'VP-ASP 6.50 - advanced session handling
strDescURL=strDescURL & arrCart(cProductid,i) & "&bc=no" & addwebsesslink
end if
end if
if strdescurl > "" then%>
<%=name%>
<%else%>
<%=name%>
<%end if%>
<%
If hideprice <> true then
If getconfig("xdualprice")="Yes" then
dualPrice=formatnumber(dualprice,getconfig("xdecimalpoint"))%>
<%
End If
next
If showtype<>"SHORT" Then
response.write "
"
response.write ""
End If
if hideprice <> true then
If showtype="SHORT" Then
response.write getlang("langcart01") & totalproductquantity & " "
End If
response.write getlang("langcommonsubtotal") & ": " & shopformatcurrency(total,getconfig("xdecimalpoint")) & vbcrlf
If getconfig("xdualprice")="Yes" then
response.write ShopFormatDualCurrency(dualtotal,getconfig("xdecimalpoint"))
end if
end if
'VP-ASP 6.50 - advanced session handling
response.write " " & getlang("langcommonviewcart") & " |" & vbcrlf
response.write " " & getlang("langcommoncheckout") & "" & vbcrlf
'VP-ASP 6.09 - add currency link to bottom of minicart
If Getconfig("xcurrencylink")="Yes" Then
dim url, cprice
cprice=shopformatnumber(total,getconfig("xdecimalpoint"))
url="http://www.x-rates.com/cgi-bin/cgicalc.cgi?value=" & cprice & "&base=" & Getconfig("Xcurrencybase")
Response.write " " & "Convert " & Getconfig("xcurrencybase") & " " & cprice & ""
end if
end sub
'********************************************************************
' creates quick go to categories
' currently used in shoppage_header.htm
'*********************************************************************
Sub NavigateShowAllCategories()
If getconfig("xlogonrequired")="Yes" then
If getsess("login")="" then
exit sub
end if
end if
if getconfig("init")="" then exit sub
dim cid, name,catSQL,i
dim strcategory, catcount, categories,maxcategories, categoryids, subcategories
Dim catdbc,catrs, hassubcategory,mylink
dim strpagename
catcount=getsess("allcatcount")
If catcount="" then catcount=0
If getconfig("xtranslate")="Yes" then
catcount=0
end if
If catcount=0 then
catcount=0
maxcategories=getconfig("xmaxcategories")
redim categories(maxcategories)
redim categoryids(maxcategories)
redim subcategories(maxcategories)
ShopOpenDatabaseP catdbc
If not catdbc.state=adStateOpen then
shopclosedatabase catdbc
exit sub
end if
catSQL="Select * from categories where cathide is null order by catdescription"
set catrs=catdbc.execute(catsql)
While Not catrs.EOF and catcount
"
end sub
Sub CorrectBooleanProgram (fieldvalue)
'If it is yes set to 1 else set to 0
If isnull(fieldvalue) or fieldvalue="" then
fieldvalue=0
end if
' Dec 31, fix
If not isnumeric(fieldvalue) then
fieldvalue=0
end if
'
If fieldvalue<>0 then
fieldvalue=yesnos(0) ' Yes
else
fieldvalue=yesnos(1) ' no
end if
end sub
Sub CorrectBooleanHuman (fieldvalue)
'If it is yes set to 1 else set to 0
If fieldvalue=yesnos(0) then
fieldvalue=1
else
fieldvalue=0
end if
end sub
'
'**************************************************************
' Used in shipping calculation to get total weight including
' feature weight
'***********************************************************
' Get total weight of products
Sub GetTotalProductWeight (conn,totalWeight,totalfeatureweight)
dim prodid, prodcode, prodname, Prodquantity, ProdPrice, prodweight
dim rsitem, deliveryarray, deliverytype, prodfeatures
dim i, calculate
dim featureweight
dim weight, shipsql
scartItem = GetSess("CartCount")
arrCart = GetSessA("CartArray")
totalweight=0
totalfeatureweight=0
' go through all products
For i = 1 to scartItem
Calculate=True
prodid=arrCart(cProductid,i)
prodcode=arrCart(cProductCode,i)
prodname= arrCart(cProductname,i)
Prodquantity=arrCart(cQuantity,i)
ProdPrice=arrCart(cUnitPrice, i)
ProdFeatures=arrCart(cProductFeatures, i)
Prodweight=arrCart(cProductweight, i)
DeliveryArray=arrCart(cDelivery, i)
If getconfig("Xdeliveryshipping")="Yes" and isarray(deliveryarray) then
Deliverytype=Deliveryarray(dDeliveryType)
If Deliveryarray(dDeliveryType)<>getlang("langDeliverySelf") then
Calculate=False
end if
end if
If calculate=True then
weight=prodweight
' Debugwrite "name=" & prodname & " quantity " & prodquantity & " weight=" & weight
if weight<>"" and isnumeric(weight) then
weight=cdbl(weight)
else
weight=0
end if
weight=weight*ProdQuantity
TotalWeight=weight+totalweight
If Getconfig("xfeatureweight")="Yes" and prodfeatures<>"" then
GetTotalfeatureweight conn, prodid, prodfeatures, featureweight
end if
featureweight=featureweight*prodquantity
totalfeatureweight=totalfeatureweight+featureweight
end if
Next
TotalWeight=totalweight+Totalfeatureweight
SetSess "Totalweight",Totalweight
'debugwrite "totalweight=" & totalweight
end sub
'*********************************************************************
' features come in as a list 5,9,11
' reread the feature record and get weight from featureother1
'****************************************************************
Sub GetTotalfeatureweight (dbc, prodid, prodfeatures, featureweight)
dim sql, rs, tweight, totalweight, weight
dim words(50), wordcount,i
featureweight=0
if prodfeatures="" then exit sub
parserecord prodfeatures,words,wordcount,","
totalweight=0
for i = 0 to wordcount-1
weight=0
sql="select * from prodfeatures where id=" & words(i)
set rs=dbc.execute(sql)
if not rs.eof then
tweight=rs("featureweight")
if not isnull(tweight) then
if isnumeric(tweight) then
weight=cdbl(tweight)
end if
end if
end if
totalweight=totalweight+weight
closerecordset rs
next
featureweight=totalweight
'debugwrite "feature weight=" & totalweight
end sub
'***********************************************************************
' write login form for shopcustomer, shopcustadminlogin
'************************************************************************
Sub ShopLOginForm_old
Dim caption
If getconfig("xcustomeruserid")="Yes" then
caption=getlang("langAdminUsername")
else
caption=getlang("langStatusEmail")
end if
If ucase(getconfig("Xpassword"))="YES" then
Response.Write("
"
addwebsessform
response.write ""
response.write ("" & getlang("langLoginForgot") & "")
else
Response.Write(""
end if
end sub
Sub ShopLOginForm
Dim caption
If getconfig("xcustomeruserid")="Yes" then
caption=getlang("langAdminUsername")
else
caption=getlang("langStatusEmail")
end if
%>
<%=getlang("langCust01")%>
<%=getlang("langlogin03")%>
<%=getlang("langcommonlogin")%>
<% dim currentpage
currentpage = request.ServerVariables("SCRIPT_NAME")
currentpage = right(currentpage, len(currentpage) - instrrev(currentpage, "/"))
If currentpage = "shopcustadminlogin.asp" then
If getconfig("xAllowcustomerregister")="Yes" Then%>
<%=getlang("langnewcustomerregister01")%>
<%'VP-ASP 6.50 - allow button to be configurable using admin
If Getconfig("xbuttonsignup")="" then%>
<%
end sub
'*********************************************************************
' Display all products in a quick shop list
'********************************************************************
Sub NavigateShowProducts
dim dbc, rs, sql
shopopendatabaseP dbc
%>
"
Closerecordset rs
shopclosedatabase dbc
end sub
Sub NavigateTopTen
if getconfig("xtopsellers") <> "Yes" then exit sub
If getconfig("xlogonrequired")="Yes" then
If GetSess("Login")="" then
exit sub
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
'******************************************************
' Find all products sold
'*******************************************************
dim strsql, dbc, odbc, useorderdb
Dim rs
strsql="select o.catalogid, sum(o.numitems) as sumofnumitems"
strsql=strsql & " from oitems o "
if getconfig("xtopsellersprocessedonly") = "Yes" then
'VP-ASP 6.08 - xdatabase was incorrectly used in (instr(lcase(xdatabasetype), "mysql")>0)
if ucase(xdatabasetype)="SQLSERVER" OR getconfig("xmysql") = "Yes" OR (instr(lcase(xdatabasetype), "mysql")>0) then
strsql=strsql & ", orders p WHERE o.orderid=p.orderid and p.oprocessed=1"
else
strsql=strsql & ", orders p WHERE o.orderid=p.orderid and p.oprocessed=TRUE"
end if
end if
strsql=strsql & " GROUP BY o.catalogid"
'VP-ASP 6.08 - xdatabase was incorrectly used in (instr(lcase(xdatabasetype), "mysql")>0)
if getconfig("xmysql") = "Yes" OR (instr(lcase(xdatabasetype), "mysql")>0)then
strsql=strsql & " ORDER BY sumofnumitems DESC"
else
strsql=strsql & " ORDER BY sum(o.numitems) DESC"
end if
'strsql="select sum(oitems.numitems) as sumofnumitems, oitems.catalogid AS catalogid "
'strsql=strsql & "from oitems "
'strsql=strsql & "inner join products on oitems.catalogid = products.catalogid "
'strsql=strsql & "where products.highercatalogid IS NULL "
'strsql=strsql & "GROUP BY oitems.catalogid "
'strsql=strsql & "UNION "
'strsql=strsql & "select sum(oitems.numitems) as sumofnumitems, products.highercatalogid AS catalogid "
'strsql=strsql & "from oitems "
'strsql=strsql & "inner join products on oitems.catalogid = products.catalogid "
'strsql=strsql & "where NOT products.highercatalogid IS NULL "
'strsql=strsql & "GROUP BY products.highercatalogid "
'strsql=strsql & "ORDER BY sumofnumitems DESC "
openorderdb odbc
set rs=odbc.execute(strsql)
TopTenProducedetail odbc,rs
closerecordset rs
shopclosedatabase odbc
end sub
'******************************************************************
' Format the top ten products
'*******************************************************************
'VP-ASP 6.08 - Sub re-written to hide out of stock products
Sub TopTenProduceDetail (dbc,rs)
dim count, fieldvalue, prs, scriptresponder, filename, lngcatalogid, ordercount,hideprod
dim strcname, strhcname, psql, pdbc,lnghighercatalogid
dim limit
limit=cint(getconfig("xtopsellerlimit"))
if limit = "" or isnull(limit) then
limit = 5
end if
'limit=10
count=0
Response.write "
"
do While Not rs.EOF and count "" then
lnghighercatalogid = prs("highercatalogid")
else
lnghighercatalogid = ""
end if
end if
closerecordset prs
'VP-ASP 6.50 - added 'childhide' to sql below to stop hidden child products from showing
if lnghighercatalogid > "" then
psql="select hp.ccategory, hp.catalogid, hp.cimageurl, p.cprice, p.cname AS cname, p.cstock as cstock, hp.cname AS hpcname, hp.hide AS hphide, p.productmatch, p.customermatch, p.hide AS childhide, hp.cdescription from products p, products hp where p.highercatalogid = hp.catalogid AND p.catalogid =" & lngcatalogid
else
psql="select *, hide AS hphide, hide AS childhide from products where catalogid=" & lngcatalogid
end if
set prs=pdbc.execute(psql)
If not prs.eof then
' response.write prs("cname") & "/" & count & "/" & limit & " "
'VP-ASP 6.50 - added 'childhide' to sql below to stop hidden child products from showing
if ((prs("hphide") = 1) or (lcase(prs("hphide")) = "true")) OR ((prs("childhide") = 1) or (lcase(prs("childhide")) = "true")) then
hideprod = true
end if
if getconfig("xstockcontrol")= "Yes" then
dim stocklowlevel
if getconfig("xstocklow") = "" or ISNULL(getconfig("xstocklow")) then
stocklowlevel = 0
else
stocklowlevel = getconfig("xstocklow")
end if
'VP-ASP 6.09 - If stockcontrol is on and the stock field of product was blank, there was an error here.
dim dbproductstock
dbproductstock = prs("cstock")
if isNull(dbproductstock) Or dbproductstock = "" Then
dbproductstock = 0
end if
if cint(dbproductstock) <= cint(stocklowlevel) then
hideprod = true
end if
' if cint(prs("cstock")) <= cint(stocklowlevel) then
' hideprod = true
' end if
end if
'VP-ASP 6.09 - only show product matching products
if getconfig("xproductmatch")="Yes" then
if lcase(prs("productmatch")) <> lcase(xproductmatch) then
hideprod = true
end if
end if
'VP-ASP 6.09 - only show customer matching products
if getconfig("xproductmatchcustomer")="Yes" then
if (lcase(prs("customermatch")) <> lcase(getsess("customerProductgroup"))) AND (NOT prs("customermatch") = "") then
hideprod = true
end if
end if
if hideprod <> true then
Response.write "
"
response.write "
"
dim rc
ShopTemplateWrite "tmp_topsellers.htm", prs, rc
response.write "
"
Response.write "
"
count=count+1
end if
end if
closerecordset prs
shopclosedatabase pdbc
rs.movenext
loop
%>
<%
end sub
Sub Navigateshowalphabet
'**********************************************************************
' create a list of letters with hyperlink to display products starting with
' those letters
' If your language has different characters please replace them in myarray
'****************************************************************************
dim alphaarray(100), alphak, letters, alphacount
If getconfig("xalphabetdisplay")<>"Yes" then exit sub
letters = getconfig("xalphabet")
if letters="" then exit sub
parserecord letters,alphaarray, alphacount,","
'response.write TableDef & tablerow & tablecolumn
for alphak=0 to alphacount-1
response.write "" & alphaarray(alphak) & ""
response.write " "
next
'response.write tablecolumnend & tablerowend & tabledefend
End Sub
Function GetProductOrderTotal
dim Prodquantity, ProdPrice
dim scartItem,arrCart, total
scartItem = GetSess("CartCount")
arrCart = GetSessA("CartArray")
total=0
' go through all products
For i = 1 to scartItem
Prodquantity=arrCart(cQuantity,i)
ProdPrice=arrCart(cUnitPrice, i)
total=total+prodquantity*prodprice
Next
SetSess "Productordertotal",Total
GetProductOrderTotal=total
end function
Function NavigateProducttotal
Dim i, stotal, iqtytotal
Dim arrCart, cartcount
Dim Quantity
iQtyTotal = 0
stotal=0
arrCart = GetSessA("CartArray")
cartcount=getsess("cartcount")
For i = 1 to cartcount
Quantity =arrCart(cQuantity,i)
sTotal = sTotal + Quantity * cDbl("0" & arrCart(cUnitPrice,i))
iQtyTotal = iQtyTotal + Quantity
Next
navigateproducttotal= shopformatcurrency(sTotal,getconfig("xdecimalpoint"))
end function
Function NavigateProductQuantity
Dim i, stotal, qtytotal
Dim arrCart, cartcount
Dim Quantity
QtyTotal = 0
arrCart = GetSessA("CartArray")
cartcount=getsess("cartcount")
For i = 1 to cartcount
Quantity =arrCart(cQuantity,i)
Qtytotal = Qtytotal + Quantity
Next
navigateproductquantity=QtyTotal
end function
Function GenerateDateList (name, currentvalue, maxvalue, daysofweek, excludelist)
dim i, j, count, downame, currentdate, displaypart
dim value, dow, dayscount, daysarray(10)
dim selected, excludes(10), excludecount
parserecord daysofweek, daysarray,dayscount, ","
If excludelist<>"" then
parserecord excludelist, excludes, excludecount,","
for i=0 to excludecount-1
If not isnumeric(excludes(i)) then excludes(i)=0
excludes(i)=clng(excludes(i))
next
end if
currentdate=currentvalue
If not isdate(currentdate) then
currentdate=date()
else
currentdate=cdate(currentdate)
end if
count=0
value=""
Generatedatelist=value
end function
'****************************************************************************
' SQL injection Function
'***************************************************************************
function Gettextfield(fieldname)
dim fieldvalue
dim badchars, i
'VP-ASP 6.50 - precautionary security fix
fieldvalue=cleanchars(request(fieldname))
if fieldvalue="" then
gettextfield=fieldvalue
exit function
end if
badChars = array("select", "drop", ";", "--", "insert", "delete", "xp_","union","char","@@")
for i = 0 to uBound(badChars)
if instr(1,fieldvalue,badchars(i),1)>0 then
fieldvalue=""
gettextfield=fieldvalue
exit function
end if
next
fieldvalue=replace(fieldvalue,"'","''")
gettextfield=fieldvalue
end function
'****************************************************************************
' SQL injection Function
'***************************************************************************
function GetIntField(fieldname)
dim fieldvalue
'VP-ASP 6.50 - precautionary security fix
fieldvalue=cleanchars(request(fieldname))
if fieldvalue<>"" then
if not isnumeric(fieldvalue) then
fieldvalue=""
end if
end if
GetIntField=fieldvalue
end function
'**************************************************************
' Used in shipping calculation to get total weight including
' feature weight
'***********************************************************
' Get total weight of products
Sub CalculateShippingdetails (conn,totalWeight,totalfeatureweight, cost, quantity)
dim prodid, prodcode, prodname, Prodquantity, ProdPrice, prodweight
dim rsitem, deliveryarray, deliverytype, prodfeatures
dim i, calculate
dim featureweight
dim weight, shipsql
scartItem = GetSess("CartCount")
arrCart = GetSessA("CartArray")
totalweight=0
totalfeatureweight=0
quantity=0
cost=0
' go through all products
For i = 1 to scartItem
Calculate=True
prodid=arrCart(cProductid,i)
prodcode=arrCart(cProductCode,i)
prodname= arrCart(cProductname,i)
Prodquantity=arrCart(cQuantity,i)
ProdPrice=arrCart(cUnitPrice, i)
ProdFeatures=arrCart(cProductFeatures, i)
Prodweight=arrCart(cProductweight, i)
calculate=checkdeliveryfree(conn, prodid)
If calculate=True then
weight=prodweight
' Debugwrite "name=" & prodname & " quantity " & prodquantity & " weight=" & weight
if weight<>"" and isnumeric(weight) then
weight=cdbl(weight)
else
weight=0
end if
weight=weight*ProdQuantity
TotalWeight=weight+totalweight
If Getconfig("xfeatureweight")="Yes" and prodfeatures<>"" then
GetTotalfeatureweight conn, prodid, prodfeatures, featureweight
end if
featureweight=featureweight*prodquantity
totalfeatureweight=totalfeatureweight+featureweight
quantity=quantity+prodquantity
cost=cost+(prodquantity*prodprice)
end if
Next
TotalWeight=totalweight+Totalfeatureweight
'Debugwrite "weight=" & totalweight & " cost=" & cost & "quantity=" & quantity
SetSess "Totalweight",Totalweight
'debugwrite "totalweight=" & totalweight
end sub
'************************************************************************
' read product record to see if it has free shiping
' returns true if product does NOT have free shipping
'***************************************************************************
Function CheckDeliveryFree(prodconn, prodid)
' returns true if product should be used in calculation
dim psql, prs, rc, shippingfree
rc=true
' ignore specific products from any shipping calculate if false is returned
If getconfig("xshippingfreeproducts")<>"Yes" then
checkdeliveryfree=rc
exit function
end if
'VP-ASP 6.09 - always have free shipping for gift certs
if prodid = getconfig("xgiftproductid") then
rc=false
checkdeliveryfree=rc
exit function
end if
psql="select * from products where catalogid=" & prodid
set prs=prodconn.execute(psql)
if not prs.eof then
shippingfree=prs("freeshipping")
if not isnull(shippingfree) then
if shippingfree<>0 then
rc=false
end if
end if
end if
closerecordset prs
checkdeliveryfree=rc
end function
Sub ShopConvertCurrencyLink (total, link)
link=""
dim msg
If Getconfig("xproductconvertcurrency")<>"Yes" Then exit sub
dim url, cprice
cprice=shopformatnumber(total,getconfig("xdecimalpoint"))
msg=getlang("langconvert") & " " & cprice
url=""
url=url & msg
url=url & ""
link=url
end sub
'
'****************************************************************
' creates category drop down list
'***************************************************************
Sub NavigateShowContent()
If getconfig("xlogonrequired")="Yes" then
If getsess("login")="" then
exit sub
end if
end if
If getconfig("init")="" then exit sub
dim cid, name,catSQL,i, contentlist, contentarray, contentcount
dim strcategory, catcount, maxcontentarray, strpagename
Dim catdbc,catrs, prevname,mylink
contentcount=getsess("contentcount")
If contentcount="" then contentcount=0
If contentcount=0 then
maxcontentarray=20
redim contentarray(maxcontentarray)
ShopOpenDatabase catdbc
If not catdbc.state=adStateOpen then
shopclosedatabase catdbc
exit sub
end if
catSQL="Select * from content where hide=0 "
catSQL=catsql & " order by messagetype,contentid desc"
set catrs=catdbc.execute(catsql)
While Not catrs.EOF and contentcountlcase(prevname) then
mylink=name
contentarray(contentcount)=name
contentcount=contentcount+1
prevname=name
end if
catrs.MoveNext
Wend
setsessa "contentarray",contentarray
setsess "contentcount",contentcount
catrs.Close
set catrs=nothing
ShopCloseDatabase catdbc
end if
contentcount=getsess("contentcount")
contentarray=getsessa("contentarray")
If contentcount="" then exit sub
if contentcount=0 then exit sub
%>
"
end sub
'
'
'***************************************************************************
' display all categories and their subcategories
' VP-ASP 5.00
' Nov 29, 2004
'*****************************************************************************
Sub NavigateShowCategorylist
dim sql, rs, level, rc, catdescription, spacing, categoryid
dim highercategoryid, hassubcategory
Dim dbconn
highercategoryid=0
shopopendatabaseP dbconn
navGeneratesql sql, highercategoryid
set rs=dbconn.execute(sql)
Response.write "
"
response.write "
"
response.write "
"
do while not rs.eof
navGetcategoryfields rs,categoryid, hassubcategory, catdescription, rc, dbconn
If rc=0 then
spacing=0
FormatcategoryList categoryid, catdescription, spacing
If hassubcategory<>"" then
Formatsubcategories categoryid,spacing, dbconn
end if
end if
rs.movenext
loop
closerecordset rs
shopclosedatabase dbconn
Response.write "
"
end sub
Sub NavGetcategoryfields (rs, categoryid, hassubcategory, strcategory, rc, catdbc)
dim strcathide
categoryid=rs("categoryid")
strcategory=rs("catdescription")
strcategory=translatelanguage(catdbc, "categories", "catdescription","categoryid", categoryid, strcategory)
hassubcategory=rs("hassubcategory")
If isnull(hassubcategory) then
hassubcategory=""
end if
strcathide=rs("cathide") ' hide field
if isnull(strcathide) then
rc=0
else
rc=4
end if
end sub
Sub navGeneratesql (sql, highercategoryid)
SQL="Select * from categories "
sql = Sql & " where highercategoryid=" & highercategoryid
if getconfig("xproductmatch")="Yes" then
'VP-ASP 6.50 - enhanced product matching
'sql=sql & " and productmatch='" & xproductmatch & "'"
sql=sql & " and "
Generateproductmatchsqlsubs sql
end if
if getconfig("xproductmatchcustomer")="Yes" then
if GetSess("CustomerProductGroup")<>"" then
sql=sql & " and customermatch='" & getsess("customerProductgroup") & "'"
end if
end if
If getconfig("xselectproductsbylanguage")="Yes" and getsess("language")<>"" then
sql=sql & " and (catlanguage='" & getsess("language") & "'"
sql=sql & " or catlanguage is null)"
end if
sql=sql & " order by " & Getconfig("xsortcategories")
end sub
Sub FormatcategoryList (id, name, spacing)
dim i
If spacing>0 then
for i = 0 to spacing
response.write " "
next
end if
response.write "" & name & "" & " " & vbcrlf
end sub
Sub Formatsubcategories (categoryid, spacing, dbconn)
dim sql, rs, rc, catdescription, hassubcategory
navGeneratesql sql, categoryid
Set rs=dbconn.execute(sql)
spacing=spacing+1
do while not rs.eof
navGetcategoryfields rs,categoryid, hassubcategory, catdescription, rc, dbconn
If rc=0 then
FormatcategoryList categoryid, catdescription, spacing
If hassubcategory<>"" then
Formatsubcategories categoryid, spacing, dbconn
end if
end if
rs.movenext
loop
spacing=spacing-1
closerecordset rs
end sub
'******************************************************************************
' associated products could be
' crossselling
' also bought
'***************************************************************************
Sub FormatassociatedProducts (dbc, sql, headercaption, displaylimit)
dim rs, strcDescURL, strurl, tempname, strmessage, tempcatalogid, tempdesc
dim limit, dcount
If Getconfig("Xcrosssellingimage")="Yes" then
FormatAssociatedwithImages dbc, sql, headercaption, displaylimit
exit sub
end if
dim hideprice
hideprice = false
if getconfig("xdisplayprices") <> "Yes" then
hideprice = true
end if
if getconfig("xpriceloggedinonly") = "Yes" then
if Getsess ("login") = "" then
hideprice = true
end if
end if
if displaylimit="" then
limit=99999
else
limit=clng(displaylimit)
end if
dcount=0
set rs=dbc.execute(sql)
if not rs.eof then%>
<%=headercaption%>
<%
'strMessage=" " & headercaption & strMessage
'Response.write strmessage
end sub
'*****************************************************************
' Cros Selling with images
'****************************************************************
Sub FormatAssociatedwithImages (dbc, sql, headercaption, displaylimit)
dim rs
dim headerok
dim limit, dcount
if displaylimit="" then
limit=99999
else
limit=clng(displaylimit)
end if
dcount=0
set rs=dbc.execute(sql)
If rs.eof then
closerecordset rs
exit sub
end if
%><%=Headercaption%>
<%
'Response.write reporttabledef & reportheadrow & ReportHeadColumn
'Response.write
'Response.write ReportHeadColumnEnd & reportrowend & tabledefend & reporttabledef
headerok=true
Do While Not rs.EOF and dcount
<%
end if
end sub
'**********************************************************************
' format one row of crossselling.
' all products must have an image
'**************************************************************************
Sub FormatAssociatedrow (rs)
dim hideprice
hideprice = false
if getconfig("xdisplayprices") <> "Yes" then
hideprice = true
end if
if getconfig("xpriceloggedinonly") = "Yes" then
if Getsess ("login") = "" then
hideprice = true
end if
end if
dim catalogid, imagefile, cname, cprice, url, cdescription
dim buttonimage, buttontext, buttonname
buttonimage=Getconfig("xbuttonmoreinfo")
buttontext=getlang("langProductExtendeddescription")
buttonname="View"
if isNull(buttonimage) Or buttonimage="" then
buttonimage=""
end if
catalogid=rs("catalogid")
imagefile=rs("cimageurl")
URL=rs("cdescurl")
If isnull(url) then
URL=getconfig("xCrossLinkURL")
end if
if ucase(URL)="SHOPEXD.ASP" then
url="shopexd.asp?id=" & rs("catalogid") & "&bc=no"
else
url="shopquery.asp?catalogid=" & rs("catalogid") & "&bc=no"
end if
'VP-ASP 6.50 - advanced session handling
url = addwebsess(url)
' add translate
cname=rs("cname")
cdescription = rs("cdescription")
dim assocdbc
shopopendatabase assocdbc
cname=translatelanguage(assocdbc, "products", "cname","catalogid", catalogid, cname)
cdescription = translatelanguage(assocdbc, "products", "cdescription","catalogid", catalogid, cdescription)
shopclosedatabase assocdbc
'Response.write reportdetailrow
%>
<%
'response.write ""
end sub
Sub loginlogouttoggle
'VP-ASP 6.08 - restore cookie if enabled so this displays correctly
if getconfig("xcookielogin") = "Yes" then
RestoreCustomerDetailsCookie
end if
if Getsess ("lastname") > "" then
'VP-ASP 6.50 - advanced session handling%>
<%=getLang("langcommonlogout")%>
<%else
'VP-ASP 6.50 - advanced session handling%>
<%=getLang("langcommonlogin")%>
<%end if
End sub
Sub welcomenote
'VP-ASP 6.08 - restore cookie if enabled so this displays correctly
if getconfig("xcookielogin") = "Yes" then
RestoreCustomerDetailsCookie
end if
if Getsess ("lastname") > "" then
response.write getlang("langloggedinas") & " " & Getsess("Firstname") & " " & Getsess("lastname") & " "
response.Write "" & getlang("langcommonlogout") & ""
else
response.write getlang("langnotloggedin") & " "
response.Write "" & getlang("langcommonlogin") & ""
end if
end sub
Sub DisplayIPAddress
dim ipaddress
ipaddress=request.servervariables("REMOTE_ADDR")
If getconfig("xdisplayIPAddress")="Yes" then
%>
<%=getlang("langipwarn01")%>
<%=request.ServerVariables("REMOTE_ADDR") & " "%>
<%=getlang("langipwarn02")%>
<%
End If
End Sub
sub inserturchinstats
if getconfig("xurchinstats") = "Yes" then
'VP-ASP 6.09 - Updated Urchin SSL URL%>
<%end if
end sub
Sub NavigateFeaturedProducts
If getconfig("xlogonrequired")="Yes" then
If GetSess("Login")="" then
exit sub
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
dim strsql, dbc, odbc, useorderdb
Dim rs
strsql="select *, cstock AS sumofnumitems from products where "
if ucase(xdatabasetype)="SQLSERVER" OR getconfig("xmysql") = "Yes" OR (instr(lcase(xdatabasetype), "mysql")>0) then
strsql=strsql & " featuredflag = 1"
else
strsql=strsql & " featuredflag = TRUE"
end if
shopopendatabaseP odbc
set rs=odbc.execute(strsql)
TopTEnProducedetail odbc,rs
closerecordset rs
shopclosedatabase odbc
end sub
'****************************************************************************
' xproductmatch can be a list of shopids
' a,b,ddd,ee
' add them all to the sql
'**************************************************************************
Sub GenerateProductmatchsqlsubs (sql)
dim shops(50), shopcount, i
parserecord xproductmatch, shops, shopcount,"," ' get all shops allowed
sql=sql & " ("
for i = 0 to shopcount-1
If i>0 then
sql=sql & " or "
end if
sql=sql & " productmatch like '%" & shops(i) & "%'"
next
sql=sql & " or productmatch is null)"
end sub
'****************************************************************************
' vpasp 6.50
' xproductmatch can be a list of shopids
' a,b,ddd,ee
' add them all to the sql
'**************************************************************************
Sub GenerateProductmatchsqlsubscat (sql)
dim shops(50), shopcount, i
parserecord xproductmatch, shops, shopcount,"," ' get all shops allowed
sql=sql & " ("
for i = 0 to shopcount-1
If i>0 then
sql=sql & " or "
end if
sql=sql & " productmatch like '%" & shops(i) & "%'"
next
'VP-ASP 6.5 - removed " and highercategoryid = 0" from line below
sql=sql & " or (productmatch is null))"
end sub
%>
<%
response.write tablecolumnend
end sub
'
'****************************************************************
' creates category drop down list
'***************************************************************
Sub NavigateShowCategories()
If getconfig("Xnavigatecategories")="No" then exit sub
If getconfig("xlogonrequired")="Yes" then
If getsess("login")="" then
exit sub
end if
end if
If getconfig("init")="" then exit sub
dim cid, name,catSQL,i
dim strcategory, catcount, categories,maxcategories
Dim catdbc,catrs, hassubcategory,mylink
'catcount=getsess("catcount")
If catcount="" then catcount=0
'VP-ASP 6.50 - advanced session handling
'If xusefilesession="Yes" then
If xsavesession="Yes" then
catcount=0
end if
If catcount=0 then
catcount=0
maxcategories=getconfig("xmaxcategories")
redim categories(maxcategories)
ShopOpenDatabaseP catdbc
If not catdbc.state=adStateOpen then
shopclosedatabase catdbc
exit sub
end if
catSQL="Select * from categories where highercategoryid=0 and cathide is null "
'VP-ASP 6.09 - add product matching to this sub
if getconfig("xproductmatch")="Yes" then
'VP-ASP 6.50 - changed below to show matching categories and categories with no association when productmatching is on
' catsql=catsql & " and productmatch='" & xproductmatch & "'"
catsql=catsql & " and (productmatch='" & xproductmatch & "' or productmatch is null)"
end if
if getconfig("xproductmatchcustomer")="Yes" then
if GetSess("CustomerProductGroup")<>"" then
catsql=catsql & " and (customermatch like '%" & getsess("customerProductgroup") & "%'"
catsql=catsql & " or customermatch is null)"
else
catsql=catsql & " and customermatch is null"
end if
end if
If getconfig("xselectproductsbylanguage")="Yes" and getsess("language")<>"" then
catsql=catsql & " and (catlanguage='" & getsess("language") & "'"
catsql=catsql & " or catlanguage is null)"
end if
'VP-ASP 6.08 - Order by config option rather than hardcoded
if getconfig("xsortcategories") <> "" then
catSQL=catsql & " order by " & getconfig("xsortcategories")
else
catSQL=catsql & " order by catdescription"
end if
' catSQL=catsql & " order by catdescription"
set catrs=catdbc.execute(catsql)
While Not catrs.EOF and catcount
