<%@ Language=VBScript %> <% '************************************************************************* ' DO NOT MODIFY THIS SCRIPT IF YOU WANT UPDATES TO WORK! ' Function : Use this page to make custom pages for your store ' Product : CandyPress Store Frontend ' Version : 6.2 ' Modified : May 2007 ' Copyright: Copyright (C) 2010 Cavallo Communications, LLC. ' See "license.txt" for this product for details regarding ' licensing, usage, disclaimers, distribution and general ' copyright requirements. If you don't have a copy of this ' file, you may request one at http://www.candypress.com '************************************************************************* Option explicit Response.Buffer = true %> <% '************************************************************************* ' DO NOT MODIFY THIS SCRIPT IF YOU WANT UPDATES TO WORK! ' Function : Database functions. ' Product : CandyPress Store Frontend ' Version : 6.2 ' Modified : May 2007 ' Copyright: Copyright (C) 2010 Cavallo Communications, LLC. ' See "license.txt" for this product for details regarding ' licensing, usage, disclaimers, distribution and general ' copyright requirements. If you don't have a copy of this ' file, you may request one at http://www.candypress.com '************************************************************************* ' Date Description ' 10/29/05 Changed how dbLocked is handled in openDB ' 06/28/08 Added test for SQL injection attack to openRSexecute ' 07/09/08 Changed test for SQL Inject attack to openRSexecut and openRSopen ' to use base code written by Dale of CPMods.com with permission '************************************************************************* '************************************************************************* 'Declare some standard ADO variables '************************************************************************* Const adOpenKeyset = 1 Const adOpenDynamic = 2 Const adOpenStatic = 3 Const adLockReadOnly = 1 Const adLockOptimistic = 3 Const adStateClosed = &H00000000 Const adUseServer = 2 Const adUseClient = 3 Const adCmdText = &H0001 Const adCmdTable = &H0002 '************************************************************************* 'Open Database Connection '************************************************************************* function openDB() on error resume next set connTemp = server.createobject("adodb.connection") connTemp.Open connString if err.number <> 0 then dim errMsg errMsg = "" _ & "Module : scripts/_INCappDBConn_.asp : openDB()

" _ & "Number : " & err.number & "

" _ & "Page : " & Request.ServerVariables("PATH_INFO") & "

" _ & "Desc : " & err.Description call errorDB("",errMsg) end if on error goto 0 if UCase(dbLocked) = "Y" then call errorDB("" & LangText("ErrStoreClosed","") & "","") call closeDB() end if end function '************************************************************************* 'Close Database Connection '************************************************************************* function closeDB() on error resume next connTemp.close set connTemp = nothing on error goto 0 end function ' ************************************************************************ ' Support routines to stop SQL Injection Attacks ' ************************************************************************ function findExploit(str) Dim testStr dim exploit dim exploitArray dim i exploit = ";drop| drop |cast|exec|create " exploitArray = split(exploit,"|") for i = 0 to UBound(exploitArray) if instr(LCase(str),exploitArray(i)) > 0 then findExploit = true exit function end if next findExploit = false end function Function stripText(strText) 'Strips the text expressions from stripText Dim objRegExp, strOutput Set objRegExp = New Regexp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern = "([""'])(?:\\\1|[\S\s])*?\1" 'Replace all text expression matches with the empty string strOutput = objRegExp.Replace(strText, "") stripText = strOutput 'Return the value of strOutput Set objRegExp = Nothing End Function '************************************************************************* 'Open RecordSet using "Execute" method '************************************************************************* function openRSexecute(mySQL) if findExploit(stripText(mySQL)) then dim exploitMsg exploitMsg = "Hacking attempt has been detected from " & Request.ServerVariables("REMOTE_ADDR") & " using the " & Request.ServerVariables("HTTP_REFERER") & " page

" & mySQL response.Redirect "notify.asp?errMsg=" & server.URLEncode(exploitMsg) end if on error resume next set openRSexecute = conntemp.execute(mySQL) if err.number <> 0 then dim errMsg errMsg = "" _ & "Module : scripts/_INCappDBConn_.asp : openRSexecute(mySQL)

" _ & "Number : " & err.number & "

" _ & "Page : " & Request.ServerVariables("PATH_INFO") & "

" _ & "Desc : " & err.Description & "

" _ & "SQL : " & mySQL call errorDB("",errMsg) end if on error goto 0 end function '************************************************************************* 'Open RecordSet using "Open" method '************************************************************************* function openRSopen(dbSource,dbCursorLoc,dbCursorType,dbLockType,dbOptions,dbCache) if findExploit(stripText(mySQL)) then dim exploitMsg exploitMsg = "Hacking attempt has been detected from " & Request.ServerVariables("REMOTE_ADDR") & " using the " & Request.ServerVariables("HTTP_REFERER") & " page

" & mySQL response.Redirect "notify.asp?errMsg=" & server.URLEncode(exploitMsg) end if on error resume next set openRSopen = Server.CreateObject("ADODB.Recordset") if dbCache > 0 then openRSopen.CacheSize = dbCache end if if dbCursorLoc > 0 then openRSopen.CursorLocation = dbCursorLoc end if openRSopen.Open dbSource,connTemp,dbCursorType,dbLockType,dbOptions if err.number <> 0 then dim errMsg errMsg = "" _ & "Module : scripts/_INCappDBConn_.asp : openRSopen(dbSource,dbCursorLoc,dbCursorType,dbLockType,dbOptions,dbCache)

" _ & "Number : " & err.number & "

" _ & "Page : " & Request.ServerVariables("PATH_INFO") & "

" _ & "Desc : " & err.Description & "

" _ & "SQL : " & dbSource call errorDB("",errMsg) end if on error goto 0 end function '************************************************************************* 'Close Recordset '************************************************************************* function closeRS(rs) on error resume next rs.Close set rs = nothing on error goto 0 end function '************************************************************************* 'Handle database errors '************************************************************************* sub errorDB(errMsgShow,errMsgHide) 'Clear output buffer and declare work variables Response.Clear dim errMsg dim hideError 'Decide which error to display, and if we must hide the error if len(trim(errMsgShow)) > 0 then errMsg = trim(errMsgShow) hideError = false else errMsg = trim(errMsgHide) hideError = true end if 'Force detailed error to be displayed if debug mode is on on error resume next if UCase(debugMode) = "Y" then if err.number = 0 then hideError = false end if end if on error goto 0 %>




System Error

<% if hideError then %> Note : The detail of this error can be viewed by activating debug mode for this store. <% else Response.Write errMsg end if %>

<% 'Close open database connections and end call closeDB() Response.End end sub %> <% '************************************************************************* ' DO NOT MODIFY THIS SCRIPT IF YOU WANT UPDATES TO WORK! ' Function : Loads and Manages the Store Configuration settings ' Product : CandyPress Store Frontend ' Version : 6.2 ' Modified : May 2007 ' Copyright: Copyright (C) 2010 Cavallo Communications, LLC. ' See "license.txt" for this product for details regarding ' licensing, usage, disclaimers, distribution and general ' copyright requirements. If you don't have a copy of this ' file, you may request one at http://www.candypress.com '************************************************************************* '************************************************************************* 'Set global defaults. Do NOT change these unless there is a problem '************************************************************************* session.LCID = 1033 'Default LCID (US English) session.Timeout = 60 '60 Minutes %> [an error occurred while processing this directive] <% dim arrConfig sub defineDim(adminType) 'Work variables dim rsTemp dim i dim mySQL on error resume next openDB() if err.number <> 0 then call closeDB() Response.redirect "sysMsg.asp?errMsg=" & server.URLEncode(err.Description) end if mySQL = "SELECT configVarType, configVar, configVal " _ & "FROM " & tablePrefix & "StoreAdmin " _ & "WHERE (((adminType)='" & adminType & "'));" set rsTemp = openRSexecute(mySQL) if not rsTemp.EOF then arrConfig = rsTemp.GetRows() closeRS(rsTemp) ' ' define the vars ' for i = 0 to ubound(arrConfig,2) 'Response.write "Dim " & arrConfig(1,i) & " = " & arrConfig(2,i) & "
" executeGlobal("Dim " & arrConfig(1,i)) next call closeDB() End sub call defineDim("C") '************************************************************************* 'Retrieve configuration settings from DB and load into local variables '************************************************************************* function loadConfig() 'Work variables dim i dim mySQL dim rsTemp ' 'Check config array if isNull(arrConfig) or isEmpty(arrConfig) or not(isArray(arrConfig)) then loadConfig = false exit function end if ' ' define the vars ' for i = 0 to ubound(arrConfig,2) err.number = 0 on error resume next Select case arrConfig(0,i) Case "L" ' long if len(trim(arrconfig(2,i))) = 0 or isnull(arrconfig(2,i)) then arrConfig(2,i) = 0 end if execute(arrConfig(1,i) & "=CLng(" & arrConfig(2,i) & ")") Case "D" ' double if len(trim(arrconfig(2,i))) = 0 or isnull(arrconfig(2,i)) then arrConfig(2,i) = 0 end if execute(arrConfig(1,i) & "=CDbl(" & arrConfig(2,i) & ")") Case Else ' string if IsEmpty(arrConfig(2,i)) or IsNull(arrConfig(2,i)) then arrConfig(2,i) = "" end if execute(arrConfig(1,i) & "=""" & replace(arrConfig(2,i),vbCrLf," ") & """") End Select if err.number <> 0 then Response.write arrConfig(1,i) & " = " & arrConfig(2,i) & " - " & err.description & " (" & err.number & ")
" end if next if err.number = 0 then loadConfig = true else loadConfig = false end if mySQL = "SELECT code, phrasekey FROM " & tablePrefix & "status" set rsTemp = openRSexecute(mySQL) do while not rsTemp.eof executeGlobal("dim " & rsTemp("phrasekey")) execute(rsTemp("phrasekey") & "=""" & replace(rsTemp("code"),vbCrLf," ") & """") rsTemp.movenext loop call closeRS(rsTemp) set rsTemp = Nothing end function %> <% '************************************************************************* ' DO NOT MODIFY THIS SCRIPT IF YOU WANT UPDATES TO WORK! ' Function : These functions and subroutines are used by the scripts ' Product : CandyPress Store Frontend ' Version : 6.2 ' Modified : May 2007 ' Copyright: Copyright (C) 2010 Cavallo Communications, LLC. ' See "license.txt" for this product for details regarding ' licensing, usage, disclaimers, distribution and general ' copyright requirements. If you don't have a copy of this ' file, you may request one at http://www.candypress.com '************************************************************************* ' Date Description ' 10/28/05 Modified getCategoryPos to use language file language_categories ' 09/26/07 Added openDB / closeDB to saveCart routine. ' 09/28/07 Added getUserAddress function to get the real IP address if WPP is using an active proxy ' 09/04/09 Added functionality for ESD password return in downloadfile ' 01/12/09 Added product discount exempt flag and support ' 03/18/09 Removed double quote from validSQL check '************************************************************************* '************************************************************************* 'Calculate cart total 'INCLUDE - Product (Item) Discounts 'INCLUDE - Order Discount 'INCLUDE - Taxes and Shipping '************************************************************************* function cartTotalTaxShipping(idOrder,idCartRow) 'Declare Variables dim mySQL,rsTemp dim discPerc dim discTotal dim taxTotal dim shipTotal 'Calculate totals if len(idOrder) > 0 and IsNumeric(idOrder) _ and len(idCartRow) > 0 and IsNumeric(idCartRow) then mySQL = "SELECT shipmentTotal, taxTotal " _ & "FROM " & tablePrefix & "cartHead " _ & "WHERE idOrder = " & validSQL(idOrder,"I") set rsTemp = openRSexecute(mySQL) if not rsTemp.EOF then shipTotal = CDbl(emptyString(rsTemp("shipmentTotal"),"0")) taxTotal = CDbl(emptyString(rsTemp("taxTotal"),"0")) cartTotalTaxShipping = cartTotal(idOrder,idCartRow) cartTotalTaxShipping = cartTotalTaxShipping + taxTotal + shipTotal end if call closeRS(rsTemp) end if cartTotalTaxShipping = CDbl(cartTotalTaxShipping) end function '************************************************************************* 'Calculate cart total 'INCLUDE - Product (Item) Discounts 'INCLUDE - Order Discount 'EXCLUDE - Taxes and Shipping '************************************************************************* function cartTotal(idOrder,idCartRow) 'Declare Variables dim mySQL,rsTemp dim discPerc dim discTotal cartTotal = 0.00 'Calculate totals if len(idOrder) > 0 and IsNumeric(idOrder) _ and len(idCartRow) > 0 and IsNumeric(idCartRow) then mySQL = "SELECT discPerc " _ & "FROM " & tablePrefix & "cartHead " _ & "WHERE idOrder = " & validSQL(idOrder,"I") set rsTemp = openRSexecute(mySQL) if not rsTemp.EOF then discPerc = CDbl(emptyString(rsTemp("discPerc"),"0")) cartTotal = cartTotalExDisc(idOrder,idCartRow) discTotal = Round(((cartTotal * discPerc) / 100),2) cartTotal = cartTotal - discTotal end if call closeRS(rsTemp) end if cartTotal = CDbl(cartTotal) end function '************************************************************************* 'Calculate cart total 'INCLUDE - Product (Item) Discounts 'EXCLUDE - Order Discount 'EXCLUDE - Taxes and Shipping '************************************************************************* function cartTotalExDisc(idOrder,idCartRow) 'Declare Variables dim mySQL,rsTemp dim quantity,unitPrice dim optionPrice,discAmt dim handlingFee cartTotalExDisc = 0.00 'Calculate totals if len(idOrder) > 0 and IsNumeric(idOrder) _ and len(idCartRow) > 0 and IsNumeric(idCartRow) then mySQL = "SELECT quantity,unitPrice,discAmt, handlingFee," _ & " (SELECT SUM(optionPrice) " _ & " FROM " & tablePrefix & "cartRowsOptions b " _ & " WHERE b.idCartRow = a.idCartRow) " _ & " AS optionPrice " _ & "FROM " & tablePrefix & "cartRows a " _ & "WHERE idOrder = " & validSQL(idOrder,"I") & " " if idCartRow > 0 then mySQL = mySQL & " AND idCartRow = " & validSQL(idCartRow,"I") end if set rsTemp = openRSexecute(mySQL) do while not rsTemp.eof quantity = CDbl(emptyString(rsTemp("quantity"),"0")) unitPrice = CDbl(emptyString(rsTemp("unitPrice"),"0")) discAmt = CDbl(emptyString(rsTemp("discAmt"),"0")) optionPrice = CDbl(emptyString(rsTemp("optionPrice"),"0")) handlingFee = CDbl(emptyString(rsTemp("handlingFee"),"0")) cartTotalExDisc = cartTotalExDisc + (quantity * (unitPrice + optionPrice - discAmt)) + (quantity * handlingFee) rsTemp.movenext loop call closeRS(rsTemp) end if cartTotalExDisc = CDbl(cartTotalExDisc) end function '************************************************************************* 'Calculate Cart Quantity '************************************************************************* function cartQty(idOrder) 'Declare Variables dim mySQL, rsTemp cartQty = 0.00 'Calculate Cart Quantity if len(idOrder) > 0 and IsNumeric(idOrder) then mySQL = "SELECT SUM(quantity) AS qTotal " _ & "FROM " & tablePrefix & "cartRows " _ & "WHERE idOrder = " & validSQL(idOrder,"I") set rsTemp = openRSexecute(mySQL) if not rsTemp.eof then if isNumeric(rsTemp("qTotal")) then cartQty = rsTemp("qTotal") end if end if call closeRS(rsTemp) end if cartQty = CDbl(cartQty) end function 'Calculate basis for order discount 'EXCLUDE - products with a Discount exemption '************************************************************************* function discTotalExempt(idOrder,idCartRow) dim mySQL,rsTemp,quantity,unitPrice,optionPrice,discAmt,discExempt discTotalExempt = 0.00 if len(idOrder) > 0 and IsNumeric(idOrder) _ and len(idCartRow) > 0 and IsNumeric(idCartRow) then mySQL = "SELECT quantity,unitPrice,discAmt,discExempt, "_ & "(SELECT SUM(optionPrice) "_ & "FROM " & tablePrefix & "cartRowsOptions a "_ & "WHERE a.idCartRow = b.idCartRow) "_ & "AS optionPrice "_ & "FROM " & tablePrefix & "cartRows b "_ & "WHERE idOrder = "& validSQL(idOrder,"I") & " " _ & "AND ((discExempt = 'N') OR (discExempt = '')) " if idCartRow > 0 then mySQL = mySQL & " AND idCartRow = "& validSQL(idCartRow,"I") end if set rsTemp = openRSexecute(mySQL) do while not rsTemp.eof quantity = CDbl(emptyString(rsTemp("quantity"),"0")) unitPrice = CDbl(emptyString(rsTemp("unitPrice"),"0")) discAmt = CDbl(emptyString(rsTemp("discAmt"),"0")) optionPrice = CDbl(emptyString(rsTemp("optionPrice"),"0")) discTotalExempt = discTotalExempt + (quantity * (unitPrice + optionPrice - discAmt)) rsTemp.movenext loop call closeRS(rsTemp) end if discTotalExempt = CDbl(discTotalExempt) end function '************************************************************************* 'Notify customer that product does not qualify for Order Discounts '************************************************************************* function itemExempt() if discExempt="Y" then %> <%=LangText("genProdDiscount","Order discount code does not apply.")%><% end if end function '************************************************************************* 'Money Formatter - Use Store LCID '************************************************************************* function moneyS(aNumber) if isNumeric(aNumber) then dim tempNumber, tempLCID tempNumber = CDbl(aNumber) tempLCID = session.LCID session.LCID = pStoreLCID 'User configured format if session("LorR") = "R" then moneyS = formatNumber(round(tempNumber,2),2) & " " & pCurrencySign else moneyS = pCurrencySign & formatNumber(round(tempNumber,2),2) end if session.LCID = tempLCID 'Default format else moneyS = aNumber end if end function '************************************************************************* 'Money Formatter - Use Default LCID '************************************************************************* function moneyD(aNumber) if isNumeric(aNumber) then moneyD = formatNumber(round(aNumber,2),2) else moneyD = aNumber end if end function '************************************************************************* 'Date formatter '************************************************************************* function formatTheDate(strDate) if isDate(strDate) then dim tempDate, tempLCID tempDate = CDate(strDate) tempLCID = session.LCID if pStoreLCID = "" then pStoreLCID = "1033" session.LCID = pStoreLCID 'User configured format formatTheDate = formatDateTime(tempDate,vbShortDate) session.LCID = tempLCID 'Default format else formatTheDate = strDate end if end function '************************************************************************* 'Money Formatter - Use Store LCID '************************************************************************* function DateTimeS(lTime,iType) dim tempLCID tempLCID = session.LCID session.LCID = pStoreLCID 'User configured format DateTimeS = formatDateTime(lTime,iType) session.LCID = tempLCID 'Default format end function '************************************************************************* 'Scan list of error FieldNames for possible match '************************************************************************* function checkFieldError(byVal FieldName, array1) dim i FieldName = Lcase(FieldName) for i = 0 to Ubound(array1) if LCase(array1(i)) = FieldName then checkFieldError = "*" exit for end if next end function '************************************************************************* 'Substitute empty or null strings with something else '************************************************************************* function emptyString(tempStr,replaceWith) if len(trim(tempStr))=0 or isEmpty(tempStr) or isNull(tempStr) then emptyString = replaceWith else emptyString = trim(tempStr) end if end function '************************************************************************* 'Payment Type Message / Description '************************************************************************* function paymentMsg(paymentType,Amount,cardNumber) if Amount > 0 then ' check for gateway type if mid(paymentType,1,3) = "50_" then ' payment type defines the implementation file which maps to the message 50_xxxxxx paymentMsg = eval("payMsg" & mid(paymentType,4)) else select case lCase(paymentType) case "mailin" paymentMsg = payMsgMailIn case "callin" paymentMsg = payMsgCallIn case "faxin" paymentMsg = payMsgFaxIn case "cod" paymentMsg = payMsgCOD case "creditcard" if len(trim(cardNumber)) > 4 then paymentMsg = payMsgCreditCard & " (" & replace(space(len(cardNumber)-4)," ","x") & right(cardNumber,4) & ")" else paymentMsg = payMsgCreditCard end if case "custom" paymentMsg = payMsgCustom case else paymentMsg = paymentType 'payMsgOther end select end if else paymentMsg = payMsgNotReq end if end function '****************************************************************** 'Get/Set idOrder from session/form/querystring '****************************************************************** function sessionCart() 'Declare Variables dim mySQL, rsTemp, idOrder idOrder = trim(session(storeID & "idOrder")) 'Check idOrder exists and Order is still Open if isEmpty(idOrder) or not IsNumeric(idOrder) then session(storeID & "idOrder") = null sessionCart = null else mySQL="SELECT idOrder " _ & "FROM " & tablePrefix & "cartHead " _ & "WHERE idOrder = " & validSQL(idOrder,"I") & " " _ & "AND (orderStatus = '" & genStatUnfinal & "' OR orderStatus = '" & genStatSaved & "') " set rsTemp = openRSexecute(mySQL) if not rstemp.eof then session(storeID & "idOrder") = idOrder sessionCart = idOrder else session(storeID & "idOrder") = null 'session(storeID & "idOrderPaySubmit") sessionCart = null 'session(storeID & "idOrderPaySubmit") end if call closeRS(rsTemp) end if end function '****************************************************************** 'Get/Set idCust from session/form/querystring '****************************************************************** function sessionCust() 'Declare Variables dim mySQL, rsTemp, idCust idCust = trim(session(storeID & "idCust")) 'Check if idCust exists on DB and is still Active if isEmpty(idCust) or not IsNumeric(idCust) then session(storeID & "idCust") = null sessionCust = null else mySQL="SELECT idCust, status FROM " & tablePrefix & "customer " _ & "WHERE idCust = " & validSQL(idCust,"I") & " " '& "AND status = 'A'" set rsTemp = openRSexecute(mySQL) if not rstemp.eof then session(storeID & "idCust") = idCust sessionCust = idCust else session(storeID & "idCust") = null sessionCust = null end if call closeRS(rsTemp) end if end function '****************************************************************** 'Format values entered into HTML form fields to prevent cross-site 'scripting and other malicious HTML. '****************************************************************** function validHTML(aString) 'Declare Variables dim tempString tempString = trim(aString) 'Check for empty values if isNull(tempString) or isEmpty(tempString) or len(tempString) = 0 then validHTML = "" exit function end if 'Clean up HTML tempString = replace(tempString,"<", " ") tempString = replace(tempString,">", " ") tempString = replace(tempString,"""","'") tempString = replace(tempString,"%"," ") validHTML = trim(tempString) end function '****************************************************************** 'Format values inserted into SQL statements before executing the 'SQL statement. This is to prevent SQL injection attacks, and to 'ensure that certain characters are interpreted correctly. '****************************************************************** function validSQL(aString,aType) 'Declare Variables dim tempString tempString = trim(aString) 'Check for empty values if isNull(tempString) or isEmpty(tempString) or len(tempString) = 0 then validSQL = "" exit function end if 'Clean up SQL if lCase(tempString) = "null" then 'Nulls validSQL = tempString else select case trim(UCase(aType)) case "I" 'Integer validSQL = CLng(tempString) case "D" 'Double validSQL = CDbl(tempString) case else 'Alphanumeric tempString = replace(tempString,"--"," ") tempString = replace(tempString,"=="," ") tempString = replace(tempString,";", " ") tempString = replace(tempString,"'","''") tempString = replace(tempString,"""","") validSQL = tempString end select end if end function '****************************************************************** 'Check a string for invalid characters '****************************************************************** function invalidChar(aString,alphaNum,addChars) dim i, checkChar invalidChar = true 'Assume invalid chars unless proven otherwise select case alphaNum case 1 'Alphanumeric [a-z, 0-9] is valid addChars = lCase("abcdefghijklmnopqrstuvwxyz0123456789" & addChars) case 2 'Numeric [0-9] is valid addChars = lCase("0123456789" & addChars) case 3 'Alpha [a-z] is valid addChars = lCase("abcdefghijklmnopqrstuvwxyz" & addChars) case else 'Only characters in addChar is valid end select for i = 1 to len(aString) checkChar = lCase(mid(aString,i,1)) if inStr(addChars,checkChar) = 0 then invalidChar = true exit function end if next invalidChar = false end function '****************************************************************** 'Convert Date to Integer '****************************************************************** function dateInt(strDate) dim qYear, qMonth, qDay, qHour, qMin, qSec qYear = year(strDate) qMonth = left("00",2-len(datePart("m",strDate))) & datePart("m",strDate) qDay = left("00",2-len(datePart("d",strDate))) & datePart("d",strDate) qHour = left("00",2-len(datePart("h",strDate))) & datePart("h",strDate) qMin = left("00",2-len(datePart("n",strDate))) & datePart("n",strDate) qSec = left("00",2-len(datePart("s",strDate))) & datePart("s",strDate) dateInt = qYear & qMonth & qDay & qHour & qMin & qSec end function '****************************************************************** 'Convert Integer to Date '****************************************************************** function dateInt2serialDate(dateInt) dim qYear, qMonth, qDay qYear = left(dateInt,4) qMonth = mid(dateInt,5,2) qDay = mid(dateInt,7,2) dateInt2serialDate = formatthedate(DateSerial(qYear,qMonth,qDay)) end function function dateInt2serialTime(dateInt) dim qHour, qMin, qSec qHour = mid(dateInt,9,2) qMin = mid(dateInt,11,2) qSec = mid(dateInt,13,2) dateInt2serialTime = timeSerial(qHour,qMin,qSec) end function '****************************************************************** 'Order Status Descriptions '****************************************************************** function orderStatusDesc(orderStatus) dim mySQL dim rsTemp mySQL = "SELECT code, phrasekey FROM " & tablePrefix & "status WHERE code = '" & validSQL(orderStatus,"A") & "';" set rsTemp = openRSexecute(mySQL) if not rsTemp.eof then orderStatusDesc = LangText(rsTemp("phrasekey"),"") else orderStatusDesc = LangText("GenStatUnknown","") end if call closeRS(rsTemp) set rsTemp = Nothing end function '************************************************************************* 'Get State Description '************************************************************************* function getStateDesc(locCountry,locState,locState2) 'Declare Variables dim mySQL, rsTemp locCountry = trim(locCountry) locState = trim(locState) locState2 = trim(locState2) 'If the alternate state is entered, return it. if len(locState2) > 0 then getStateDesc = locState2 else 'Get State description on database. if len(locCountry) = 0 or len(locState) = 0 then getStateDesc = locState else 'Get State Name mySQL = "SELECT StateName " _ & "FROM " & tablePrefix & "States " _ & "WHERE StateCode = '" & validSQL(locState,"A") & "';" set rsTemp = openRSexecute(mySQL) if rsTemp.eof then getStateDesc = locState else getStateDesc = rsTemp("StateName") end if call closeRS(rsTemp) end if end if end function '************************************************************************* 'Get Country Description '************************************************************************* function getCountryDesc(locCountry) 'Declare Variables dim mySQL, rsTemp locCountry = trim(locCountry) 'Check Country code if len(locCountry) = 0 then getCountryDesc = locCountry else 'Get Country Name mySQL = "SELECT CountryName " _ & "FROM " & tablePrefix & "Country " _ & "WHERE CountryCode = '" & validSQL(locCountry,"A") & "';" set rsTemp = openRSexecute(mySQL) if rsTemp.eof then getCountryDesc = locCountry else getCountryDesc = rsTemp("CountryName") end if call closeRS(rsTemp) end if end function '************************************************************************* 'Check if an Item is a Downloadable Item. If it is, return the filename 'of the downloadable file. '************************************************************************* function downloadFile(qIdOrder,idCartRow) 'Declare Variables dim mySQL, rsTemp 'Get Filename mySQL="SELECT b.fileName, a.dlpassword " _ & "FROM " & tablePrefix & "cartRows a, " & tablePrefix & "products b " _ & "WHERE idOrder = " & validSQL(qIdOrder,"I") & " " _ & "AND idCartRow = " & validSQL(idCartRow,"I") & " " _ & "AND b.idProduct = a.idProduct " _ & "AND NOT (b.fileName IS NULL " _ & "OR b.fileName = '') " set rsTemp = openRSexecute(mySQL) if rsTemp.eof then downloadFile = "" dlpassword = "" else downloadFile = trim(rsTemp("fileName")) dlpassword = trim(rsTemp("dlpassword")) end if call closeRS(rsTemp) end function '********************************************************************* 'Check if str1 and str2 matches and return "selected" if they do '********************************************************************* function checkMatch(str1,str2) if lCase(trim(str1)) = lCase(trim(str2)) then checkMatch = " selected " else checkMatch = "" end if end function '********************************************************************* 'Check if str1 and str2 matches and return "checked" if they do '********************************************************************* function checkMatchChecked(str1,str2) if lCase(trim(str1)) = lCase(trim(str2)) then checkMatchChecked = " checked " else checkMatchChecked = "" end if end function '********************************************************************* 'Display average rating for a product '********************************************************************* function ratingImage(prodRating) if not isNumeric(prodRating) then ratingImage = "" exit function end if select case round(prodRating,0) case 1 ratingImage = "" case 2 ratingImage = "" case 3 ratingImage = "" case 4 ratingImage = "" case 5 ratingImage = "" case else ratingImage = "" end select end function '********************************************************************* 'Save a cart (order) for later retrieval '********************************************************************* function saveCart(idOrder,idCust) 'Declare Variables dim mySQL, rsTemp, rsTemp2 call openDB() if isNumeric(idOrder) and isNumeric(idCust) then 'Get some customer info mySQL="SELECT idCust,Name,LastName,CustomerCompany,Phone," _ & " Email,Address,City,Zip,locState,locCountry " _ & "FROM " & tablePrefix & "customer " _ & "WHERE idCust = " & validSQL(idCust,"I") set rsTemp = openRSexecute(mySQL) if not rstemp.eof then 'Update cartHead mySQL = "UPDATE " & tablePrefix & "cartHead SET " _ & "orderStatus = '" & uCase(genStatSaved) & "'," _ & "idCust = " & validSQL(rsTemp("idCust"),"I") & "," _ & "[Name] = '" & validSQL(rsTemp("Name"),"A") & "'," _ & "LastName = '" & validSQL(rsTemp("LastName"),"A") & "'," _ & "CustomerCompany = '" & validSQL(rsTemp("CustomerCompany"),"A") & "'," _ & "Phone = '" & validSQL(rsTemp("Phone"),"A") & "'," _ & "Email = '" & validSQL(rsTemp("Email"),"A") & "'," _ & "Address = '" & validSQL(rsTemp("Address"),"A") & "'," _ & "City = '" & validSQL(rsTemp("City"),"A") & "'," _ & "Zip = '" & validSQL(rsTemp("Zip"),"A") & "'," _ & "locState = '" & validSQL(rsTemp("locState"),"A") & "'," _ & "locCountry = '" & validSQL(rsTemp("locCountry"),"A") & "' " _ & "WHERE idOrder = " & validSQL(idOrder,"I") set rsTemp2 = openRSexecute(mySQL) call closeRS(rsTemp2) end if call closeRS(rsTemp) end if call closeDB() end function '************************************************************************* 'Calculate an option's price for as it relates to a particular product. '************************************************************************* function getOptionPrice(priceToAdd, percToAdd, prodPrice) 'Declare variables dim tempPrice 'Check parameters if not(isNumeric(priceToAdd) and IsNumeric(percToAdd) and IsNumeric(prodPrice)) then getOptionPrice = 0 exit function end if if isNull(priceToAdd) or isNull(percToAdd) or isNull(prodPrice) then getOptionPrice = 0 exit function end if if priceToAdd = 0 and percToAdd = 0 then getOptionPrice = 0 exit function end if 'Determine Option Price if priceToAdd > 0 and percToAdd > 0 then tempPrice = Round(((prodPrice * percToAdd) / 100),2) if tempPrice > priceToAdd then getOptionPrice = tempPrice else getOptionPrice = priceToAdd end if elseif priceToAdd > 0 then getOptionPrice = priceToAdd else getOptionPrice = Round(((prodPrice * percToAdd) / 100),2) end if end function '****************************************************************** 'Get affiliate ID and set session variables '****************************************************************** function getIdAffiliate(idAffiliate) 'Declare Variables dim mySQL, rsTemp 'Check idAffiliate parameter if isEmpty(idAffiliate) or isNull(idAffiliate) or not isNumeric(idAffiliate) then exit function end if 'Check idAffiliate on DB mySQL="SELECT commPerc FROM " & tablePrefix & "customer " _ & "WHERE idCust = " & validSQL(idAffiliate,"I") & " " _ & "AND status = 'A' " _ & "AND affiliate = 'Y' " set rsTemp = openRSexecute(mySQL) if not rstemp.eof then 'Set session variables session(storeID & "idAffiliate") = idAffiliate session(storeID & "commPerc") = rsTemp("commPerc") end if call closeRS(rsTemp) end function '****************************************************************** 'Add delimiters to a date if used in an SQL statement '****************************************************************** function addDateDel(dateVal) if dbType = 0 then 'MS Access dateVal = "#" & dateVal & "#" else 'SQL Server dateVal = "'" & dateVal & "'" end if addDateDel = dateVal end function '****************************************************************** 'Return current date or time '****************************************************************** function currDateTime(dtFormat,timeOffSet) currDateTime = dateAdd("h",timeOffSet,now()) if UCase(dtFormat) = "D" then currDateTime = formatDateTime(currDateTime,vbShortDate) elseif UCase(dtFormat) = "T" then currDateTime = formatDateTime(currDateTime,vbLongTime) else '("DT") currDateTime = formatDateTime(currDateTime,vbGeneralDate) end if end function '************************************************************************* 'Get full category position, ie : cat1 > cat2 > cat3 '************************************************************************* function getCategoryPos(IDCategory,tempStr,linksYN) 'Declare variables dim mySQL, rsTemp const separator = " > " dim links dim language language = session("language") if len(language) = 0 then language = languageDefault end if 'Read DB and construct string mySQL = "SELECT idCategory,idParentcategory,categoryDesc,breadCrumb,breadCrumbLinked " _ & "FROM " & tablePrefix & "categories " _ & "WHERE idCategory = " & validSQL(idCategory,"I") set rsTemp = openRSexecute(mySQL) 'See if we have already defined links links = UCase(linksYN) if not rsTemp.eof and language = languageDefault then select case links case "N" if len(rsTemp("breadCrumb")) > 0 then getCategoryPos = rsTemp("breadCrumb") & separator & rsTemp("categoryDesc") exit function end if case "Y" if len(rsTemp("breadCrumbLinked")) > 0 then getCategoryPos = rsTemp("breadCrumbLinked") & separator & "" & rsTemp("categoryDesc") & "" exit function end if end Select end if if rsTemp.eof then 'When we reach beginning of node, strip unneeded separator characters tempStr = mid(tempStr,len(separator)+1) end if do while not rsTemp.eof if UCase(trim(linksYN & "")) = "Y" then tempStr = separator & "" & langCategory(rsTemp("idCategory"),"categoryDesc",rsTemp("categoryDesc")) & "" & tempStr else tempStr = separator & langCategory(rsTemp("idCategory"),"categoryDesc",rsTemp("categoryDesc")) & tempStr end if tempStr = getCategoryPos(rsTemp("idParentcategory"),tempStr,linksYN) rsTemp.movenext loop call closeRS(rsTemp) getCategoryPos = tempStr end function '********************************************************************* 'Sort a one dimensional array '********************************************************************* %> <% Function SortNumArray(arrInput) SortArray = Split(SortVBNumArray(arrInput), Chr(8)) End Function Function SortArray(arrInput) SortArray = Split(SortVBArray(arrInput), Chr(8)) End Function '******************************************************************** ' Format US / CA phone numbers '******************************************************************** function formatPhone(number) dim oneChar dim i for i = 1 to len(number) oneChar = mid(number,i,1) if IsNumeric(oneChar) then formatPhone = formatPhone & oneChar end if next if len(formatPhone) < 10 or len(formatPhone) > 10 then formatPhone = "" end if end function '**************************************'************************************************************************************* ' ' Display order status selection options ' '************************************************************************************* function showStatusOptions() dim mySQL, rsTemp mySQL = "SELECT code, phrasekey FROM " & tablePrefix & "status" set rsTemp = openRSexecute(mySQL) 'Response.write mySQL & "
" do while not rsTemp.eof 'Response.write rsTemp("phrasekey") & "
" %> <% rsTemp.movenext loop call closeRS(rsTemp) set rsTemp = Nothing end function '********************************************************************** 'Generate a Random Key '********************************************************************** function rndKey(upperbound) randomize rndKey = DatePart("y",now()) _ & DatePart("h",now()) _ & DatePart("n",now()) _ & DatePart("s",now()) _ & Int(upperbound * Rnd + 1) end function Function generateKey(keyLength) dim sDefaultChars dim iKeyLength dim iDefaultCharactersLength dim iCounter dim iPickedChar dim sMyKey ' Initialize variables sDefaultChars = "abcdefghijklmnopqrstuvxyzABCDEFGHIJKLMNOPQRSTUVXYZ0123456789" iKeyLength = keyLength iDefaultCharactersLength = Len(sDefaultChars) ' Initialize the random number generator Randomize 'Loop for the number of characters password is to have For iCounter = 1 To iKeyLength iPickedChar = Int((iDefaultCharactersLength * Rnd) + 1) sMyKey = sMyKey & Mid(sDefaultChars, iPickedChar, 1) Next generateKey = sMyKey End Function '********************************************************************** 'Generate a Random Key '********************************************************************** function getidSFcookie() dim cookieKey dim rsTemp cookieKey = generateKey(15) ' Create empty favorites record set rsTemp = openRSopen(tablePrefix & "CustSF",adUseServer,adOpenKeySet,adLockOptimistic,adCmdTable,0) rsTemp.AddNew rsTemp("dateCreated") = currDateTime("DT",timeOffSet) rsTemp("dateCreatedInt")= dateInt(currDateTime("DT",timeOffSet)) rsTemp("cookieKey") = cookieKey rsTemp.update Response.cookies(storeID & "idSF") = cookieKey Response.cookies(storeID & "idSF").expires = dateAdd("d",30,now()) Response.cookies(storeID & "idSF").path = "/" getidSFcookie = rsTemp("idSF") call closeRS(rsTemp) end function '********************************************************************* 'DEPRECATED Functions '******************************* function checkString(str1) 'No longer required. checkString = str1 end function function money(aNumber) 'Replaced by moneyS() and moneyD() money = moneyS(aNumber) end function Function CheckCAPTCHA(valCAPTCHA) dim SessionCAPTCHA SessionCAPTCHA = Trim(Session("CAPTCHA")) Session("CAPTCHA") = vbNullString if Len(SessionCAPTCHA) < 1 then CheckCAPTCHA = False exit function end if if CStr(SessionCAPTCHA) = CStr(valCAPTCHA) then CheckCAPTCHA = True else CheckCAPTCHA = False end if End Function '****************************************************************************** ' Return the actual address of the Remote Address. Corrects for server proxies, ' such as Cisco Cache and Content Engines by using the HTTP_X_FORWARDED_FOR ' address when present (suggested by surehosting.com) '****************************************************************************** function getUserAddress() if IsEmpty(Request.ServerVariables("HTTP_X_FORWARDED_FOR")) OR InStr(lCase(Request.ServerVariables("HTTP_X_FORWARDED_FOR")), "unknown") > 0 then getUserAddress = Request.ServerVariables("REMOTE_ADDR") else getUserAddress = Request.ServerVariables("HTTP_X_FORWARDED_FOR") If InStr(getUserAddress, ",") > 0 Then getUserAddress = Mid(getUserAddress, 1, InStr(getUserAddress, ",")-1) elseIf InStr(getUserAddress, ";") > 0 Then getUserAddress = Mid(getUserAddress, 1, InStr(getUserAddress, ";")-1) end if end if end function %> <% dim mySQL, connTemp, rsTemp, rsTemp2, idOrder, idCust call openDB() if loadConfig() = false then call errorDB(LangText("ErrConfig",""),"") end if idOrder = sessionCart() idCust = sessionCust() %> [an error occurred while processing this directive] <% call closeDB() sub cartMain() %>

Order your Rubber City Armory
Tactical Upgrade today!

<% mysql = "select idproduct,description,descriptionlong,smallimageurl,price,stock,backinstock from " & tablePrefix & "products where active = -1 order by sortorder " set rsTemp = openRSexecute(mySQL) do while not rstemp.eof %>
" alt="<%=rstemp("description")%>" class="shadow-box">

<%=rstemp("description")%>

<%=moneys(rstemp("price"))%>

<%=rstemp("descriptionlong")%>

<% if rstemp("stock") > 0 then %> '" style="font-family:fjalla_oneregular;" class="highlight shadow font18">ORDER YOURS TODAY <% else if rstemp("backinstock") <> "" then%> Back in stock:<%=rstemp("backinstock")%> <%end if end if%>

<%rstemp.movenext loop call closers(rstemp) end sub %>