<%
End Sub
Sub CloseTable
%>
<%
End Sub
Sub WriteOrderRow (objRec)
if processed<>0 then
response.write ReportDetailRowX
else
response.write ReportDetailRow
end if
response.write ReportDetailColumn & "#" & objRec("orderid") & "" & ReportDetailcolumnend
response.write ReportDetailColumn & objRec("ofirstname") & " " & objRec("olastname") & ReportDetailcolumnend
response.write ReportDetailColumn & objRec("odate") & ReportDetailcolumnend
response.write ReportDetailColumn & shopformatcurrency(objrec("orderamount"),getconfig("xdecimalpoint")) & ReportDetailcolumnend
response.write ReportDetailColumn & objRec("ocardtype") & ReportDetailcolumnend
response.write ReportDetailColumn & objRec("ocountry") & ReportDetailcolumnend
response.write ReportDetailRowEnd
End sub
Sub WriteOrderTrackingRow (objRec)
response.write ReportDetailRow
response.write ReportDetailColumn & "#" & objRec("trackid") & "" & ReportDetailcolumnend
response.write ReportDetailColumn & objRec("trackname") & ReportDetailcolumnend
response.write ReportDetailColumn & objRec("trackdate") & ReportDetailcolumnend
response.write ReportDetailColumn & objrec("tracktime") & ReportDetailcolumnend
response.write ReportDetailColumn & left(objRec("trackcomment"), 50)
if len(objRec("trackcomment")) > 50 then response.write "..."
response.write ReportDetailcolumnend
response.write ReportDetailRowEnd
End sub
Sub WriteCustAuthRow (objRec)
response.write ReportDetailRow
response.write ReportDetailColumn & "#" & objRec("contactid") & "" & ReportDetailcolumnend
response.write ReportDetailColumn & objRec("firstname") & ReportDetailcolumnend
response.write ReportDetailColumn & objRec("lastname") & ReportDetailcolumnend
response.write ReportDetailColumn & objrec("email") & ReportDetailcolumnend
response.write ReportDetailcolumnend
response.write ReportDetailRowEnd
End sub
'VP-ASP 6.50 - RMA
Sub WriteOrderRMARow (objRec)
response.write ReportDetailRow
response.write ReportDetailColumn & "#" & objRec("rmaid") & "" & ReportDetailcolumnend
response.write ReportDetailColumn & objRec("rmaname") & ReportDetailcolumnend
response.write ReportDetailColumn & objRec("rmacreationdate") & ReportDetailcolumnend
response.write ReportDetailColumn & objrec("rmacustomeraction") & ReportDetailcolumnend
response.write ReportDetailColumn & left(objRec("rmacustomercomment"), 50)
if len(objRec("rmacustomercomment")) > 50 then response.write "..."
response.write ReportDetailcolumnend
response.write ReportDetailRowEnd
End sub
Sub GetHeaderMenu
dim menuconn, rs, sql, i
ShopOpenDatabase menuconn
'Get all menu items for this section
sql = "SELECT DISTINCT fldmenu, fldsection FROM tblaccess WHERE fldsection = '"
if (getsess("headermenu") = "occasional") then
sql = sql & "occasional"
elseif (getsess("headermenu") = "setup") then
sql = sql & "setup"
else
sql = sql & "everyday"
end if
sql = sql & "' ORDER BY fldmenu"
if getsess("headermenu") = "setup" then
sql = sql & " DESC"
end if
set rs=menuconn.execute(sql)
'go back to start of recordset so we can write the submenus for each menu item
if (getsess("nomenuitems") <> true) and (not getsess("headermenu") = "setup") then
rs.movefirst
i = 1
while not rs.eof
' WriteSubMenuOpen i, rs("fldmenu"), rs("fldsection")
WriteSubMenuItems i, rs("fldmenu"), rs("fldsection")
' WriteSubMenuClose
i = i + 1
rs.movenext
wend
end if
closerecordset rs
ShopCloseDatabase menuconn
End SUb
sub writeheadermenu
dim menuconn, rs, sql, i
WriteMenuOpen
ShopOpenDatabase menuconn
'Get all menu items for this section
sql = "SELECT DISTINCT fldmenu, fldsection FROM tblaccess WHERE fldsection = '"
if (getsess("headermenu") = "occasional") then
sql = sql & "occasional"
elseif (getsess("headermenu") = "setup") then
sql = sql & "setup"
else
sql = sql & "everyday"
end if
sql = sql & "' ORDER BY fldmenu"
if getsess("headermenu") = "setup" then
sql = sql & " DESC"
end if
set rs=menuconn.execute(sql)
i = 1
if rs.eof then
'write the section name because there are no menu items
response.write ucase(left(getsess("headermenu"), 1)) & lcase(right(getsess("headermenu"), len(getsess("headermenu")) - 1))
else
'write out menu items
if getsess("headermenu") <> "setup" then
%> | <%
end if
while not rs.eof
if getsess("headermenu") = "setup" then
if getconfig("xnewconfigmode") = "Yes" then
WriteMenuItemLink rs("fldmenu"), rs("fldsection")
end if
else
WriteMenuItem i, rs("fldmenu"), rs("fldsection")
end if
i = i + 1
rs.movenext
wend
end if
WriteMenuClose
end sub
Sub generatetabs
%>
- >Admin Home
<%
'VP-ASP 6.50 - hide menu items that user doesn't have access to
dim tabdbc, tabrs
shopopendatabase tabdbc
list = GetAccess(getsess("shopadmin"), tabdbc)
'CONFIG TAB
if getconfig("xnewconfigmode") = "Yes" then
set tabrs = tabdbc.execute("SELECT * FROM tblaccess WHERE fldurl like 'shopa_config.asp?tab=%' AND fldauto in (" & list & ") ORDER BY fldOrder, fldName")
else
set tabrs = tabdbc.execute("SELECT * FROM tblaccess WHERE fldurl like 'shopa_config.asp%' AND fldauto in (" & list & ") ORDER BY fldOrder, fldName")
end if
if not tabrs.eof then%>
- >Set-Up
<%end if
set tabrs = tabdbc.execute("SELECT * FROM tblaccess WHERE fldsection = 'everyday' AND fldauto in (" & list & ") ORDER BY fldOrder, fldName")
if not tabrs.eof then
%>
- >Everyday Tasks
<% end if
set tabrs = tabdbc.execute("SELECT * FROM tblaccess WHERE fldsection = 'occasional' AND fldauto in (" & list & ") ORDER BY fldOrder, fldName")
if not tabrs.eof then
%>
- >Occasional Tasks
<%end if
closerecordset tabrs
shopclosedatabase tabdbc
%>
<%
end sub
Sub GetTotalCustomers
dim sql, myconn, headerrecs
OpenCustomerDB myconn
'get number of customers today
sql = "select count(contactid) as customernumber from customers"
set headerrecs = myconn.execute(sql)
if not headerrecs.eof then
response.write headerrecs("customernumber")
else
response.write "0"
end if
closerecordset headerrecs
shopclosedatabase myconn
End Sub
'***************************************************************
' get sum of orders today
'***************************************************************
Sub GetTodaysTotal
dim sql, myconn, headerrecs
openorderdb myconn
'get total of orders today
sql = "select sum(orderamount) as todayorder from orders WHERE odate = " & datedelimit(datepart("yyyy",date) & "/" & datepart("m",date) & "/" & datepart("d",date))
'only show processed orders. Comment out these line to show all orders
if (ucase(xdatabasetype)="SQLSERVER") or (getconfig("xmysql")="Yes") OR (instr(ucase(xdatabasetype), "MYSQL") > 0) then
sql = sql & " AND oprocessed = 1"
else
sql = sql & " AND oprocessed = TRUE"
end if
'only show orders that match end of order valid payments. Comment out the lines below to show all orders
dim validpayments, types
if instr(Getconfig("xendofordervalidpayments"), ",") > 0 then
validpayments = split(Getconfig("xendofordervalidpayments"), ",")
sql = sql & " AND ("
for each types in validpayments
sql = sql & " ocardtype = '" & types & "' OR"
next
sql = left(sql, len(sql) - 2)
sql = sql & ")"
else
sql = sql & " AND ocardtype = '" & Getconfig("xendofordervalidpayments") & "'"
end if
'COMMENT ABOVE THIS LINE-----------------------------------------------------------------------------------
set headerrecs = myconn.execute(sql)
if not headerrecs.eof then
if headerrecs("todayorder") > "" then
response.write shopformatcurrency(headerrecs("todayorder"), 2)
else
response.write "0"
end if
else
response.write "0"
end if
closerecordset headerrecs
shopclosedatabase myconn
End Sub
Sub GetMonthsTotal
dim sql, myconn, headerrecs
openorderdb myconn
'get total of orders this month
'VP-ASP 6.08 - Total was tallying all months from all years. Now does current month of current year
sql = "select sum(orderamount) as monthorder from orders WHERE MONTH(odate) = '" & datepart("m",date) & "' AND YEAR(odate) = '" & datepart("yyyy",date) & "'"
'only show processed orders. Comment out this line to show all orders
if (ucase(xdatabasetype)="SQLSERVER") or (getconfig("xmysql")="Yes") OR (instr(ucase(xdatabasetype), "MYSQL") > 0) then
sql = sql & " AND oprocessed = 1"
else
sql = sql & " AND oprocessed = TRUE"
end if
'only show orders that match end of order valid payments. Comment out the lines below to show all orders
dim validpayments, types
if instr(Getconfig("xendofordervalidpayments"), ",") > 0 then
validpayments = split(Getconfig("xendofordervalidpayments"), ",")
sql = sql & " AND ("
for each types in validpayments
sql = sql & " ocardtype = '" & types & "' OR"
next
sql = left(sql, len(sql) - 2)
sql = sql & ")"
else
sql = sql & " AND ocardtype = '" & Getconfig("xendofordervalidpayments") & "'"
end if
'COMMENT ABOVE THIS LINE-----------------------------------------------------------------------------------
set headerrecs = myconn.execute(sql)
if not headerrecs.eof then
if headerrecs("monthorder") > "" then
response.write shopformatcurrency(headerrecs("monthorder"), 2)
else
response.write "0"
end if
else
response.write "0"
end if
closerecordset headerrecs
shopclosedatabase myconn
End Sub
'******************************************************************
' get total orders for year
'**********************************************************************
Sub GetYearsTotal
dim sql, myconn, headerrecs
openorderdb myconn
'get total of orders this year
sql = "select sum(orderamount) as yearorder from orders WHERE YEAR(odate) = '" & datepart("yyyy",date) & "'"
'only show processed orders. Comment out this line to show all orders
if (ucase(xdatabasetype)="SQLSERVER") or (getconfig("xmysql")="Yes") OR (instr(ucase(xdatabasetype), "MYSQL") > 0) then
sql = sql & " AND oprocessed = 1"
else
sql = sql & " AND oprocessed = TRUE"
end if
'only show orders that match end of order valid payments. Comment out the lines below to show all orders
dim validpayments, types
if instr(Getconfig("xendofordervalidpayments"), ",") > 0 then
validpayments = split(Getconfig("xendofordervalidpayments"), ",")
sql = sql & " AND ("
for each types in validpayments
sql = sql & " ocardtype = '" & types & "' OR"
next
sql = left(sql, len(sql) - 2)
sql = sql & ")"
else
sql = sql & " AND ocardtype = '" & Getconfig("xendofordervalidpayments") & "'"
end if
'COMMENT ABOVE THIS LINE-----------------------------------------------------------------------------------
set headerrecs = myconn.execute(sql)
if not headerrecs.eof then
if headerrecs("yearorder") > "" then
response.write shopformatcurrency(headerrecs("yearorder"), 2)
else
response.write "0"
end if
else
response.write "0"
end if
closerecordset headerrecs
shopclosedatabase myconn
End Sub
sub writeSubMenuOpen (theNumber, theName, theSection)
dim paddedNumber
if theNumber < 10 then
paddedNumber = "0" & theNumber
end if%>
<%end sub
sub writeMenuOpen%>
<%end sub
sub writeMenuClose%>
<%end sub
Sub WriteMenuItem (theNumber, theName, theSection)
'VP-ASP 6.50 - hide menu items that user doesn't have access to
if menuArray(theNumber) = "false" then
exit sub
end if
dim theUnpaddedNunber
theUnpaddedNunber = theNumber
if theNumber < 10 then
theNumber = "0" & theNumber
end if%>
|
|
<%end sub
Sub WriteMenuItemLink (theName, theSection)
'VP-ASP 6.50 - hide menu items that user doesn't have access to
dim configdbc, configrs
shopopendatabase configdbc
list = GetAccess(getsess("shopadmin"), configdbc)
set configrs = configdbc.execute("SELECT * FROM tblaccess WHERE fldsection = '" & theSection & "' AND fldMenu = '" & theName & "' AND fldauto in (" & list & ") ORDER BY fldOrder, fldName")
if not configrs.eof then
%>
|
|
<%
end if
closerecordset configrs
shopclosedatabase configdbc
end sub
sub headerjavascript%>
<%end sub
sub getnumberofmenuitems
dim numconn, numrs, numsql, k
ShopOpenDatabase numconn
'Get all menu items for this section
numsql = "SELECT DISTINCT fldmenu, fldsection FROM tblaccess WHERE fldsection = '"
if (getsess("headermenu") = "occasional") then
numsql = numsql & "occasional"
elseif (getsess("headermenu") = "setup") then
numsql = numsql & "setup"
else
numsql = numsql & "everyday"
end if
numsql = numsql & "' ORDER BY fldmenu"
set numrs=numconn.execute(numsql)
k = 1
if numrs.eof then
'set numberofmenuitems = nothing because there are no menu items
setsess "numberOfMenuItems", ""
setsess "nomenuitems", true
else
'count number of menu items
while not numrs.eof
k = k + 1
numrs.movenext
wend
setsess "numberOfMenuItems", k
setsess "nomenuitems", false
end if
closerecordset numrs
ShopCloseDatabase numconn
End sub
Sub WriteSubMenuItems (theNumber, theName,theSection)
dim menuconn, rs, m
ShopOpenDatabase menuconn
list = GetAccess(getsess("shopadmin"), menuConn)
if list = "" then
responseredirect "shopa_logoff.asp"
end if
'Get all menu items for this sub-menu
sql = "SELECT * FROM tblaccess WHERE "
sql = sql & "fldsection = '" & theSection & "' AND fldMenu = '" & theName & "' "
sql = sql & " AND fldauto in (" & list & ") ORDER BY fldOrder, fldName"
set rs=menuconn.execute(sql)
'VP-ASP 6.08 - if a menu had no items, it was breaking the display. Moving this call outside IF statement fixes
%>//Contents for menu <%=theNumber%>
var menu<%=theNumber%>=new Array()
<%
if rs.eof then
'VP-ASP 6.50 - hide menu items that user doesn't have access to
menuArray(theNumber) = "false"
'response.write "No menu items
"
'VP-ASP 6.08 - Change the way this line is written (from response.write)
%>menu<%=theNumber%>[0]='No menu items'
<%
else
menuArray(theNumber) = "true"
'write out menu items
dim mm
mm = 0
while not rs.eof%>
menu<%=theNumber%>[<%=mm%>]='" class="nav"><%
dim menuWord
'VP-ASP 6.50.1 - check that fldname is not null before replacing
If Not IsNull(rs("fldname")) Then
menuWord = replace(rs("fldname"), "getlang(""", "")
menuWord = replace(rs("fldname"), """)", "")
end if
if instr(menuword ," ") > 0 then
dim menuWordArray, thing
menuWordArray = split(menuword," ")
for each thing in menuWordArray
if lcase(left(thing, 4)) = "lang" then
if lcase(left(thing, 8)) = "language" then
response.write thing & " "
else
response.write getlang(thing) & " "
end if
else
response.write thing & " "
end if
next
else
if lcase(left(menuword, 4)) = "lang" then
if lcase(left(menuword, 8)) = "language" then
response.write menuword & " "
else
response.write getlang(menuword) & " "
end if
else
response.write menuword & " "
end if
end if%>
'
<%mm = mm + 1
rs.movenext
wend
end if
closerecordset rs
ShopCloseDatabase menuconn
End SUb
'******** Display table
Sub DisplayAdminPage
%><%
end sub
Sub GetMenuItems
dim adminconn, adminrs, adminsql, newrow
newrow = 0
ShopOpenDatabase adminconn
'Get All Top Level menu items from database
adminsql = "select DISTINCT fldMenu from tblaccess where fldsection = '" & getsess("headermenu") & "'"
set adminrs = adminconn.execute(adminsql)
'Write out top level menu item
while not adminrs.eof
'VP-ASP 6.50 - hide menu items that user doesn't have access to
list = GetAccess(getsess("shopadmin"), adminconn)
set rs = adminconn.execute("SELECT * FROM tblaccess WHERE fldmenu = '" & adminrs("fldmenu") & "' ORDER BY fldOrder, fldName")
dim showmenuitem
showmenuitem = false
if rs.eof then
showmenuitem = false
else
while not rs.eof
if instr("," & list & ",", "," & rs("fldauto") & ",") > 0 then
showmenuitem = true
end if
rs.movenext
wend
if showmenuitem = false then
'do nothing
else
if newrow = 0 then
%><%
end if
newrow = newrow + 1
%>
 /big_<%=adminrs("fldmenu")%>.gif"> |
<%=ucase(left(adminrs("fldmenu"), 1)) & lcase(right(adminrs("fldmenu"), len(adminrs("fldmenu")) - 1))%> |
<%'Get sub menu items
GetSubMenuItems adminrs("fldmenu")%>
|
<%if newrow = 3 then
%>
| |
<%
newrow = 0
end if
end if
end if
closerecordset rs
adminrs.movenext
wend
set adminrs = nothing
ShopCloseDatabase adminconn
End Sub
Sub GetSubMenuItems (thisMenu)
dim subadminconn, subadminrs, subadminsql
dim list
ShopOpenDatabase subadminconn
list = GetAccess(getsess("shopadmin"), subadminConn)
'Get All Sub Level menu items from database
subadminsql = "select * from tblaccess where fldMenu = '" & thisMenu & "' AND fldauto in (" & list & ") ORDER BY fldorder, fldname"
set subadminrs = subadminconn.execute(subadminsql)
while not subadminrs.eof
%>
| |
"><%
dim submenuWord
submenuWord = replace(subadminrs("fldname"), "getlang(""", "")
submenuWord = replace(subadminrs("fldname"), """)", "")
if instr(submenuWord ," ") > 0 then
dim submenuWordArray, thing
submenuWordArray = split(submenuWord," ")
for each thing in submenuWordArray
if lcase(left(thing, 4)) = "lang" then
if lcase(left(thing, 8)) = "language" then
response.write thing & " "
else
response.write getlang(thing) & " "
end if
else
response.write thing & " "
end if
next
else
if lcase(left(submenuWord, 4)) = "lang" then
if lcase(left(submenuWord, 8)) = "language" then
response.write submenuWord & " "
else
response.write getlang(submenuWord) & " "
end if
else
response.write submenuWord & " "
end if
end if
%> |
<%
subadminrs.movenext
wend
closerecordset subadminrs
ShopCloseDatabase subadminconn
End Sub
Sub AdminPageHeaderFull
%>
<%
end sub
'**************************************************************
' adds quote or # depdending on database
'**************************************************************
Function datedelimitheader (indate)
dim datedelim, newdate
newdate=indate
datedelim="" ' access does not like delimiyers around partial dates
if ucase(xdatabasetype)="SQLSERVER" or getconfig("xmysql")="Yes" OR instr(ucase(xdatabasetype),"MYSQL") > 0 then
datedelim="'"
end if
dateDelimitheader = datedelim & newdate & datedelim
end function
sub outofstockproducts
dim sql
dim myconn, headerrecs
shopopendatabaseP myconn
'get number of out of stock products
sql = "select count(catalogid) as outofstock from products where (cstock < 1) OR (cstock is null)"
set headerrecs = myconn.execute(sql)
if not headerrecs.eof then
response.write headerrecs("outofstock")
else
response.write "0"
end if
closerecordset headerrecs
shopclosedatabase myconn
end sub
Function Removehtmlheaders(itemname, CR)
dim workrecord, firstchar, morefields, pos, endpos, length
dim token
workrecord=replace(itemname,"
",CR)
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
workrecord = replace(workrecord, """", "'")
Removehtmlheaders=workrecord
end function
'VP-ASP 6.09 - dynamically include header file while allowing for ASP to be included in this file
public dyninclude, include_vars, include_vars_count
dim objfschk
dim regFltr,regFltr2
set dyninclude = new cls_include
set objfschk = server.createobject("scripting.filesystemobject")
set regFltr = new regexp
set regFltr2 = new regexp
class cls_include
private sub class_initialize()
set include_vars = server.createobject("scripting.dictionary")
include_vars_count = 0
end sub
private sub class_deactivate()
include_vars.removeall
set include_vars = nothing
set include = nothing
end sub
public default function dyninclude(byval str_path)
err.clear
dim str_source,init_path
if str_path <> "" then
if (instr(str_path,":") > 0) then
init_path = str_path
else
init_path = server.mappath(str_path)
end if
str_source = readfile(str_path)
if str_source <> "" then
str_source = processincludes (str_source, init_path, 0)
convert2code str_source
formatcode str_source
if str_source <> "" then
' if request.querystring("debug") = 1 then
' response.write str_source
' response.end
' else
executeglobal str_source
' end if
end if
end if
end if
end function
private sub convert2code(str_source)
dim i, str_temp, arr_temp, int_len, basecount
basecount = include_vars_count
if str_source <> "" then
if instr(str_source,"%" & ">") > instr(str_source,"<" & "%") then
str_temp = replace(str_source,"<" & "%","¿%")
str_temp = replace(str_temp,"%" & ">","¿")
if left(str_temp,1) = "¿" then str_temp = right(str_temp,len(str_temp) - 1)
if right(str_temp,1) = "¿" then str_temp = left(str_temp,len(str_temp) - 1)
arr_temp = split(str_temp,"¿")
int_len = ubound(arr_temp)
if (int_len + 1) > 0 then
for i = 0 to int_len
str_temp = arr_temp(i)
str_temp = replace(str_temp,vbcrlf & vbcrlf,vbcrlf)
if left(str_temp,2) = vbcrlf then str_temp = right(str_temp,len(str_temp) - 2)
if right(str_temp,2) = vbcrlf then str_temp = left(str_temp,len(str_temp) - 2)
if left(str_temp,1) = "%" then
str_temp = right(str_temp,len(str_temp) - 1)
if left(str_temp,1) = "=" then
str_temp = right(str_temp,len(str_temp) - 1)
str_temp = "response.write " & str_temp
end if
else
if str_temp <> "" then
include_vars_count = include_vars_count + 1
include_vars.add include_vars_count, str_temp
str_temp = "response.write include_vars.item(" & include_vars_count & ")"
end if
end if
if right(str_temp,2) <> vbcrlf then str_temp = str_temp
arr_temp(i) = str_temp
next
str_source = join(arr_temp,vbcrlf)
end if
else
if str_source <> "" then
'VP-ASP 6.50.1 - if var already exists, delete it before reinstating it
if include_vars.Exists("var") then include_vars.Remove("var")
include_vars.add "var", str_source
str_source = "response.write include_vars.item(""var"")"
end if
end if
end if
end sub
private function processincludes(tmp_source, curdir, curdepth)
dim int_start, str_path, str_mid, str_temp, localdir,str_method,newdir
if (curdepth < 20) then ' Maximum allowable depth. Just in case we get two files including each other
localdir = left(curdir, len(curdir)-len(objfschk.GetFileName(curdir)))
tmp_source = replace(tmp_source,""))
do until int_start = 0
str_mid = lcase(getbetween(tmp_source,""))
if (str_mid <> "") then int_start = 1
if int_start > 0 then
str_method = lcase(trim(getbetween(str_mid," ","=")))
str_temp = lcase(getbetween(str_mid,chr(34),chr(34)))
str_temp = trim(str_temp)
if (str_method = "file") then
newdir = objfschk.BuildPath(localdir,replace(str_temp,"/","\"))
str_path = processincludes(readfile(newdir), newdir, curdepth+1)
tmp_source = replace(tmp_source,"",str_path & vbcrlf)
elseif (str_method = "virtual") then
newdir = server.mappath(str_temp)
str_path = processincludes(readfile(newdir), newdir)
tmp_source = replace(tmp_source,"",str_path & vbcrlf)
else
tmp_source = replace(tmp_source,"","" & vbcrlf)
end if
end if
int_start = instr(tmp_source,"