<% ' Copyright (C) 1998-2005 Cyberstrong Internet Services, Inc. All Rights Reserved ' ' This file has been seeded with unique information at point of sale and ' is traceable to its purchaser. ' ' Your license agreement forbids the removal of this notice. ' Funcs.asp - Shared functions for global use. ' VerifyLogin(): Login fence. Returns ONLY if user login is already established. Public Sub VerifyLogin () If (Session(sesLoginOK)) Then Session(sesLoginOK) = True Exit Sub End If If ((Request.Form("LoginID") = cstLoginID) AND (Request.Form("Password") = cstPassword)) Then Session(sesLoginOK) = True Exit Sub End If If ((cstAuthorizedHours > 0) And (Not strIsEmpty(cstCatalogName))) Then If (Request.Cookies(cstCatalogName)("AuthorizedUntil") <> "") Then If ( _ (CDate(Request.Cookies(cstCatalogName)("AuthorizedUntil")) >= Now()) AND _ (Request.Cookies(cstCatalogName)("AuthorizedBy") = GetCRC(Crypt(cstCatalogName, cstEncryptionKey, "enc")))) Then Session(sesLoginOK) = True Exit Sub End If End If End If ' Authorization timed-out, force login ... Response.Redirect("mLogin.asp") End Sub ' Display page header Public Sub DisplayPageHeader (ByVal PageNo, ByVal PageTitle, ByVal Options) Dim DemoMsg, TextOnly, WideMode, UseAdminMode, UseCartLogo, LockMsg DemoMsg = "" If (gblDemoMode) Then DemoMsg = "Demonstration Only" End If LockMsg = "" If (isLocked()) Then LockMsg = "
Your eShop is locked" End If TextOnly = CBool(InStr(Options, "t") <> 0) UseAdminMode = CBool(InStr(Options, "a") <> 0) WideMode = CBool(InStr(Options, "w") <> 0) UseCartLogo = CBool(InStr(Options, "c") <> 0) On Error Resume Next Select Case isInAdmin OR UseAdminMode Case True ' Displaying in admin area ... If (Not TextOnly) Then wl("") End If wl("") wl("") wl("") wl("
" & DemoMsg & "" & PageTitle & "" & LockMsg & "
") ' Display revision warning if needed ... If (Not isDataBaseCurrent()) Then wl("
") wl("safina eShop: Database Upgrade Needed: ") wl("To upgrade your database, please click the Maintenance tab then click ") wl("""Upgrade or Fix"" and follow the instructions therein.") wl("
") End If Case False ' Displaying in cart area ... If (gblDemoMode) Then wl(DemoMsg & "

") End If If (cstProgressBarEnabled AND (Not TextOnly)) Then wl("") wl("") wl("") ' Spacer wl("
") End If End Select ' All pages ... ' Demo expired ... If (Date() >= TrialExpires) Then wl("") wl("") ' Spacer wl("") wl("") ' Spacer wl("
") wl("



Sorry, this demonstration version of safina eShop has expired.

") wl("

You may purchase a copy by visiting our Web site at:

") wl("

www.cyberstrong.com/eshop

") wl("
") Response.End End If ' Trial banner ... If (isTrialMode) Then Dim ExpireDateFormated, tmpDate tmpDate = UCase(FormatDateTime(TrialExpires, vbLongDate)) ExpireDateFormated = Mid(tmpDate, Instr(tmpDate, ",") + 1) wl("") wl("") wl("") wl("") wl("") ' Spacer wl("
FREE TRIAL VERSION
EXPIRES " & ExpireDateFormated & "
Click here to purchase safina eShop
Help us improve safina eShop by taking our one minute survey! Click here.
") End If ' Running totals ... If (cstRunningTotalsEnabled AND (PageNo = "10")) Then wl("") wl("") wl("") ' Spacer wl("
" & GetRunningTotal() & "
") End If ' Display version info on request ... If ((GetURLValue("AbouteShop")) OR _ (GetURLValue("AbouteShop") = "true")) Then Call DisplayAbout() wl("
") End If TrialLockOk = True End Sub ' ConnectString() - Return connection string... Public Function ConnectString() Dim DBPath ' User supplied Connect String (Generally for SQL server use) If Not (UserExit(usrGetConnectString, 0, 0, 0, 0, ConnectString)) Then ' Default is MSAccess based connect string ... If (UserExit(usrGetDBPath, 0, 0, 0, 0, DBPath)) Then Select Case True Case Mid(DBPath, 2, 1) = ":" ' Fully specified path name ... ConnectString = "driver={Microsoft Access Driver (*.mdb)};dbq=" & DBPath Case LCase(Mid(DBPath, 1, 4)) = "dsn=" ' DSN ... ConnectString = DBPath Case Else ' Relative path name ... ConnectString = "driver={Microsoft Access Driver (*.mdb)};dbq=" & Server.MapPath(DBPath) End Select Else ' Default path is eShop.mdb, for backward compatibility ... ConnectString = "driver={Microsoft Access Driver (*.mdb)};dbq=" & Server.MapPath("database\eShop.mdb") End If End If End Function ' dbOpen() - Create a connection to the database ... ' Valid modes are: ' "r": May be read-only ' "w": Must have write permissions ' "l": Lock system on insufficient permissions ' "s": Silent mode. Suppress ODBC error display (from shopper) Public Function dbOpen(argMode) Dim x On Error Resume Next Set dbOpen = Server.CreateObject("ADODB.Connection") dbOpen.Open ConnectString() dbOpen.Mode = adModeReadWrite If (dbOpen.Errors.Count > 0) Then For Each x in dbOpen.Errors ' Default condition to fail connect is "rw" ... ConnectFailed = CBool((x.Number <> 0) OR (Instr(x.Description, "read-only") <> 0)) ' Read only (silent) access required ... If ((argMode = "r") OR (argMode = "rs")) Then ConnectFailed = CBool(x.Number <> 0) If (ConnectFailed) Then Call Log(0, "eShop/dbOpen(): Error# " & x.Number & " (" & x.Description & ")") Call Log(0, "eShop/dbOpen(): ConnectString: " & Session("ConnectString")) Exit For End If Next ' Lock eShop when "l" mode present ... If (ConnectFailed AND (InStr(argMode, "s") = 0)) Then If (InStr(argMode, "l") <> 0) Then Call DisplayMaintPage() Response.End Else wl("
" & _ "eShop: Database cannot be opened in mode '" & GetOpenModeDesc(argMode) & _ "'.  Click here for server database tests.") Response.End End If End If End If ' Used for pop-up windows ... Session("Conn") = dbOpen End Function ' dbClose() - Close the current connection to the database. ' Ignore error if already closed. Public Sub dbClose(argConnection) On Error Resume Next argConnection.Close ' Preserve our session ... Set Session(SessionPrefix & "OurSession") = OurSession End Sub ' isLocked() - Returns True if eShop's maintance lock is Set Public Function isLocked() isLocked = Cbool(FileExists(RootPath & "Maint.flg") And (Session("CartInPopUp") <> "yes")) End Function ' GetOpenModeDesc() - Get open mode description from mode string Public Function GetOpenModeDesc(ByVal argMode) GetOpenModeDesc = "" If (InStr(argMode, "r") <> 0) Then GetOpenModeDesc = GetOpenModeDesc & "Read/" If (InStr(argMode, "w") <> 0) Then GetOpenModeDesc = GetOpenModeDesc & "Write/" If (InStr(argMode, "l") <> 0) Then GetOpenModeDesc = GetOpenModeDesc & "Lock/" If (InStr(argMode, "s") <> 0) Then GetOpenModeDesc = GetOpenModeDesc & "Silent/" ' Remove final trailing "/" GetOpenModeDesc = Left(GetOpenModeDesc, Len(GetOpenModeDesc) - 1) End Function ' GetRunningTotal() - Calculate and return shopping cart total ... Public Function GetRunningTotal() Dim Qty, Total, i Total = 0 Qty = 0 For i = 1 To iCount If (aryCart(cartItemType, i) = "usr") Then Qty = Qty + aryCart(cartItemQuantity, i) End If Total = Total + aryCart(cartTotalPrice, i) Next Select Case True Case Qty = 0 GetRunningTotal = "(Your shopping cart is empty)" Case Qty = 1 GetRunningTotal = "(Your shopping cart contains 1 item totaling " & OurFormatCurrency(Total) & ")" Case Qty > 1 GetRunningTotal = "(Your shopping cart contains " & Qty & " items totaling " & OurFormatCurrency(Total) & ")" End Select End Function ' GetFormAction() - Get form action, handles both traditional ' and graphic form submit buttons. ' Button names must be bracketed in | characters. ' or be prefixed with 'btn' Public Function GetFormAction() Dim x, sa ' Standard grey button ... If (Request.Form("Action") <> "") Then GetFormAction = Request.Form("Action") Exit Function End If 'If (Request.Form("calc") <> "") Then 'GetFormAction = Request.Form("calc") 'Exit Function 'End If ' Graphic button ... For Each x in Request.Form ' Old style ... If (Left(x, 1) = "|") Then sa = Split(x, "|") GetFormAction = sa(1) Exit For End If ' New style ... If (LCase(Left(x, 3)) = "btn") Then sa = Split(mid(x, 4), ".") GetFormAction = sa(0) Exit For End If Next End Function ' IIf() - Immediate "if" Public Function IIf(ByVal argbValue, argTrue, argFalse) If (argbValue) Then IIf = argTrue Else IIf = argFalse End If End Function ' Build FormErrorMsg ... Public Sub CheckMissingField (ByVal FieldName, ByVal FieldDesc) if Request.Form(FieldName) = "" Then FormErrorMsg = FormErrorMsg & "Please complete the field '" & FieldDesc & "'
" End If End Sub ' Display all form fields (debug only) ... Public Sub DisplayFormFields() Dim FieldName, i ' Display URL line ... wl("URL:" & "

") For Each FieldName in Request.QueryString wl(FieldName & ": <" & Request.QueryString(FieldName) & ">
") Call Log(0, "URL: " & FieldName & ": <" & Request.QueryString(FieldName) & ">") Next wl("") ' Display form fields ... wl("
Form Fields:" & "

") For Each FieldName in Request.Form wl(FieldName & ": <" & Request.Form(FieldName) & ">
") Call Log(0, "Form: " & FieldName & ": <" & Request.Form(FieldName) & ">") Next wl("") ' Display session values ... If (strContains(Request.ServerVariables("SERVER_SOFTWARE"), "IIS")) Then wl("
Session Values:" & "

") For i = 0 to Session.Contents.Count-1 Select Case VarType(Session.Contents.Item(i)) Case vbEmpty, vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDate, vbString, vbBoolean wl(Session.Contents.Key(i) & ": <" & Session.Contents.Item(i) & ">
") Call Log(0, "Session: " & Session.Contents.Key(i) & ": <" & Session.Contents.Item(i) & ">") Case Else wl(Session.Contents.Key(i) & ": <Object>
") Call Log(0, "Session: " & Session.Contents.Key(i) & ": ") End Select Next wl("") End If End Sub ' Test for file existance ... Public Function FileExists(ByVal FileName) On Error Resume Next Dim obj, AbsFileName ' Check for fully qualified path, if not map it ... If (Mid(FileName, 2, 1) = ":") Then AbsFileName = FileName Else AbsFileName = Server.MapPath(FileName) End If set obj = Server.CreateObject("Scripting.FileSystemObject") FileExists = obj.FileExists(AbsFileName) set obj = Nothing End Function ' GetFileDate() - Returns a file date Public Function GetFileDate(ByVal argSource) Dim obj, f, Source On Error Resume Next Source = Server.MapPath(argSource) Set obj = Server.CreateObject("Scripting.FileSystemObject") If (obj.FileExists(Source)) Then Set f = obj.GetFile(Source) GetFileDate = f.DateLastModified End If Set f = Nothing : Set obj = Nothing End Function ' Log() - Log events to log file. ' - For security reasons, log file name is unique to each eShop. Public Sub Log (ByVal Level, ByVal Line) Dim AbsFileName, FileObj, FileOut ' Fail quietly if permission problems ... On Error Resume Next Set FileObj = Server.CreateObject("Scripting.FileSystemObject") Set FileOut = FileObj.OpenTextFile(RootPath & GetLogFileName(), 8, True) FileOut.WriteLine(Now() & " " & GetScriptName() & " " & Line & " (" & _ Request.ServerVariables("REMOTE_HOST") & ")") FileOut.Close Set FileOut = Nothing Set FileObj = Nothing End Sub ' GetLogFileName() - Return the name of the eShop log file. Public Function GetLogFileName() ' Name log file with database name, to protect it from outsiders. GetLogFileName = Replace(cstDatabaseName, ".mdb", ".txt") End Function ' DevNote() - Write note to log file and page. ' - safina development only, not used in production releases. Public Sub DevNote(ByVal argNote) wl(GetScriptName() & ": " & Server.HTMLEncode(argNote) & "
") Response.Flush Call Log(0, GetScriptName() & ": " & argNote) End Sub ' GetScriptName - Returns the name of the currently running script Public Function GetScriptName() Dim i, PathName, LastSlash PathName = Request.ServerVariables("SCRIPT_NAME") For i = 1 To Len(PathName) Step 1 If Mid(PathName, i, 1) = "/" Then LastSlash = i End If Next GetScriptName = Mid(PathName, LastSlash + 1) End Function ' GetFileName - Returns the name of the file in the given path name ' - Remove trailing "?" if present Public Function GetFileName(ByVal argPathName) Dim a1, a2 a1 = Split(Replace(argPathName, "\", "/"), "/") a2 = Split(a1(Ubound(a1)), "?") GetFileName = a2(0) End Function ' GetFileExt() - Returns file extension from file or path name... Public Function GetFileExt(ByVal argName) Dim p p = InStrRev(argName, ".") GetFileExt = IIF(p > 0, Mid(argName, p + 1), "") End Function ' GetPathName - Returns the name path for the currently running script ... Public Function GetPathName() Dim i, PathName, LastSlash PathName = Request.ServerVariables("SCRIPT_NAME") For i = 1 To Len(PathName) Step 1 If Mid(PathName, i, 1) = "/" Then LastSlash = i End If Next GetPathName = Mid(PathName, 1, LastSlash) End Function ' ReadFile() - Returns a file as a string ... Public Function ReadFile(ByVal argSource) Dim oTxtFile, Source, stdio On Error Resume Next Set stdio = CreateObject("Scripting.FileSystemObject") ReadFile = "" Source = IIF(Left(argSource, 1) = "\", RootPath & Mid(argSource, 2), Server.MapPath(argSource)) If stdio.FileExists(Source) Then Set oTxtFile = stdio.OpenTextFile(Source, 1) ReadFile = oTxtFile.ReadAll oTxtFile.Close Else Call Log(0, "ReadFile(): File '" & Source & "' does not exist.") ReadFile = "" End If Set stdio = Nothing End Function ' GetProductImagePath() - Get product image, substitute "no photo" if non-existent Public Function GetProductImagePath(ByVal argImagePath) Select Case True Case Not cstProductImagesEnabled GetProductImagePath = ResourcePath & "images/nophoto.gif" Case Left(LCase(Trim(argImagePath)), 4) = "http" GetProductImagePath = argImagePath Case FileExists(RootPath & argImagePath) GetProductImagePath = ResourcePath & argImagePath Case Else GetProductImagePath = ResourcePath & "images/nophoto.gif" End Select End Function ' SecureURL() - Return Secure version of given URL Public Function SecureURL(ByVal URL) ' Check to see if user has assigned a SSL prefix first ... If (InStr(LCase(cstSecurePrefix), "yourdomain.com") <> 0) Then SecureURL = RootHTTPPath & IIF(isInAdmin, AdminFolder & "/", "") & URL Else SecureURL = Trim(cstSecurePrefix) & IIF(isInAdmin, AdminFolder & "/", "") & URL End If ' Protect NetScape 7.0 and later from backslashes ... SecureURL = Replace(SecureURL, "\", "/") End Function ' NonSecureURL() - Return Non-Secure version of given URL Public Function NonSecureURL(ByVal URL) ' Check to see if user has assigned a non-secure prefix first ... Select Case True Case (LCase(Mid(URL, 1, 7)) = "http://") NonSecureURL = URL Case (InStr(LCase(cstNonSecurePrefix), "yourdomain.com") <> 0) NonSecureURL = RootHTTPPath & IIF(isInAdmin, AdminFolder & "/", "") & URL Case Else NonSecureURL = Trim(cstNonSecurePrefix) & IIF(isInAdmin, AdminFolder & "/", "") & URL End Select ' Protect NetScape 7.0 and later from backslashes ... NonSecureURL = Replace(NonSecureURL, "\", "/") End Function ' DisplayLink() - Displays a link using optional graphic. Public Sub DisplayLink (ByVal Link, ByVal Image, ByVal AltText) If (Image <> "") Then Response.Write("" & AltText & "") Else Response.Write("[ " & AltText & " ]") End If End Sub ' DisplayMaintPage - Disallow access to site for maintenance purposes Public Sub DisplayMaintPage() wl("") wl("

Sorry, we are presently updating our system.") wl("
Please try again soon.") wl("

Thank you for visiting " & cstCatalogName & ".") wl("

") Call DisplayLink(cstHomeURL, ResourcePath & "custom/images/Home.gif", "Home") wl("
") If (gblDemoMode) Then wl("
") wl("
Webmaster: ") wl("In new installations, the display of this message when your cart is not 'locked' for maintenance ") wl("is most commonly caused by incorrect file permissions ") wl("on your Web server or failure to upgrade your eShop database when installing a code upgrade. ") wl("In the administration area of your eShop 1) Upgrade your database or 2) Run eShop's Server Test Utility ") wl("to diagnose and correct this problem.") wl("

") wl("This diagnostic message displays only when safina eShop is running in") wl("demonstration mode.
") End If End Sub ' DisplayAbout() - Display About safina Info Public Sub DisplayAbout() Dim Feature wl("
") wl("Cyberstrong eShop Version: " & gblVersionNo & " Build: " & cstBuildNum & "
") wl("Server Version: " & Request.ServerVariables("SERVER_SOFTWARE") & "
") wl("VBScript Version: ") wl(ScriptEngineMajorVersion & "." & ScriptEngineMinorVersion) wl("Build: " & ScriptEngineBuildVersion & "
") wl("Database Type: " & cstServerType & "
") wl("Current Server Time: " & FormatDateTime(Now(), vbGeneralDate) & "
") wl("Root Path: " & LCASE(RootPath) & "
") wl("Root HTTP Path: " & LCASE(RootHTTPPath) & "
") wl("Server Path: " & LCASE(Request.ServerVariables("PATH_TRANSLATED")) & "
") wl("Remote Host: " & LCASE(Request.ServerVariables("REMOTE_HOST")) & "
") wl("Server Name: " & LCASE(Request.ServerVariables("SERVER_NAME")) & "
") wl("Server Port: " & LCASE(Request.ServerVariables("SERVER_PORT")) & "
") wl("
Installed Features:
") For Each Feature in FeatureInstalled wl(FeatureInstalled(Feature).Name & " (" & FormatNumber(FeatureInstalled(Feature).Version, 2) & ")
") Next wl("") End Sub ' ConfirmSessionOk() - Confirm that the current session has not timed out ... Public Sub ConfirmSessionOk(argTestValue) If (Trim(Session(argTestValue)) = "") Then wl("") wl("

Sorry, the session was lost or has timed-out.") wl("
Please try again.") wl("

") Call DisplayLink(cstHomeURL, ResourcePath & "custom/images/Home.gif", "Home") wl("
") Response.End End If End Sub ' IsValidEmail() - Validate eMail address Function IsValidEmail(ByVal sString) Dim sEmail, nIndex, nDotIndex IsValidEmail = False sString = Trim(sString) nIndex = InStr(1, sString, "@") If nIndex < 2 Then Exit Function End If nDotIndex = InStrRev(sString, "." ) If nDotIndex < nIndex + 2 Then Exit Function End If If InStr( nIndex + 1, sString, "@" ) > nIndex Then Exit Function End If If nDotIndex > Len(sString) - 2 Then Exit Function End If IsValidEmail = True End Function ' Min() - Return the minimum of two values Public Function Min(ByVal arg1, ByVal arg2) If (arg1 <= arg2) Then Min = arg1 Else Min = arg2 End If End Function ' Max() - Return the maximum of two values Public Function Max(ByVal arg1, ByVal arg2) If (arg1 >= arg2) Then Max = arg1 Else Max = arg2 End If End Function ' wl() - Write one line to the browser Public Sub wl(ByVal argText) Response.Write(argText & vbCrLF) End Sub ' isMatch() - True if Pattern found in String ... Function isMatch(argString, argPattern) Dim regEx, Matches On Error Resume Next Set regEx = New RegExp regEx.Pattern = argPattern regEx.IgnoreCase = True regEx.Global = True Set Matches = regEx.Execute(argString) isMatch = CBool(Matches.Count >= 1) Set regEx = Nothing End Function ' ReplaceRegEx() - Replace regular expression in string ... Function ReplaceRegEx(ByVal argString, ByVal argSearchFor, ByVal argReplaceWith, ByVal argOptions) Dim RegEx On Error Resume Next Set RegEx = New RegExp RegEx.Pattern = argSearchFor RegEx.Global = True RegEx.IgnoreCase = CBool(InStr(argOptions, "i") <> 0) ReplaceRegEx = RegEx.Replace(argString & "", argReplaceWith) Set RegEx = Nothing End Function ' StripHTML() - Strip HTML tags from string ... Function StripHTML (strText) Dim RegEx On Error Resume Next Set RegEx = New RegExp RegEx.Pattern = "<[^>]*>" RegEx.Global = True StripHTML = RegEx.Replace(strText, "") Set RegEx = Nothing End Function ' strContains() - Returns True if the given string contains the given argument ... Public Function strContains(ByVal argString, argContains) strContains = CBool(InStr(Trim(LCase(argString & "")), Trim(LCase(argContains))) <> 0) End Function ' strIsEmpty() - Returns true for empty or null strings ... Public Function strIsEmpty(ByVal argString) strIsEmpty = CBool((Trim(argString & "")) = "") End Function ' FormatOptions() - Format options ordered, for display Public Function FormatOptions(ByVal argOptions) Dim s s = argOptions If (IsNull(s) OR (s = "")) Then FormatOptions = "" Else FormatOptions = "
" & Replace(s, "[", "
[") & "" End If End Function ' FormatCC() - Format CC number for easier transcribing during manual entry. ' - Insert one space every four digits. Public Function FormatCC(ByVal argCCNumber) Dim i, pos, c, num ' No formatting required if string is empty or null... If (strIsEmpty(argCCNumber)) Then FormatCC = "" Exit Function End If FormatCC = CStr("") num = CStr("") ' Extract numbers only ... For pos = 1 To Len(argCCNumber) ' Grab the current character c = Mid(argCCNumber, pos, 1) ' If the character is a digit or *, append it to our new number If (IsNumeric(c) Or (c = "*")) Then num = num & c Next ' Build it back up again with spaces. If (Len(num) = 13) Then ' 13 digits, use format xxxx xxx xxx xxx FormatCC = Mid(num, 1, 4) & " " For i = 5 To Len(num) Step 1 FormatCC = FormatCC & Mid(num, i, 1) If (((i - 4) MOD 3) = 0) Then FormatCC = FormatCC & " " End If Next Else ' 16 digits, Use format xxxx xxxx xxxx xxxx For i = 1 To Len(num) Step 1 FormatCC = FormatCC & Mid(num, i, 1) If ((i MOD 4) = 0) Then FormatCC = FormatCC & " " End If Next End If End Function ' OurFormatCurrency() - Format dollars in specified currency ' - A dash in the symbol means substitute a blank Public Function OurFormatCurrency(ByVal argAmount) Dim TokenList, ReplaceWhat, ReplaceWith If (Not strIsEmpty(argAmount)) Then If (cstCurrencySymbol <> "") Then TokenList = Split(cstCurrencySymbol & "/", "/") Select Case UBound(TokenList) Case 1 : ReplaceWhat = "$" : ReplaceWith = TokenList(0) Case 2 : ReplaceWhat = TokenList(0) : ReplaceWith = TokenList(1) End Select OurFormatCurrency = Replace(FormatCurrency(argAmount), ReplaceWhat, _ Replace(ReplaceWith, "-", " ")) Else OurFormatCurrency = FormatCurrency(ToNumber(argAmount)) End If Else OurFormatCurrency = "" End If End Function ' OurFormatDateTime - Format Date and time Unix style ... Public Function OurFormatDateTime(ByVal argDate, ByVal argTemplate) OurFormatDateTime = argTemplate OurFormatDateTime = Replace(OurFormatDateTime, "%YYYY", Year(argDate)) OurFormatDateTime = Replace(OurFormatDateTime, "%MM", ZeroFill(Month(argDate), 2)) OurFormatDateTime = Replace(OurFormatDateTime, "%DD", ZeroFill(Day(argDate), 2)) OurFormatDateTime = Replace(OurFormatDateTime, "%hh", ZeroFill(Hour(argDate), 2)) OurFormatDateTime = Replace(OurFormatDateTime, "%mm", ZeroFill(Minute(argDate), 2)) OurFormatDateTime = Replace(OurFormatDateTime, "%ss", ZeroFill(Second(argDate), 2)) End Function ' ToNumber() - Remove all non-numeric chars from a string. Public Function ToNumber(ByVal argString) Dim i, n ToNumber = "" If (Trim(argString & "") = "") Then ToNumber = 0 Exit Function End If For i = 1 To Len(argString) Step 1 n = Mid(argString, i, 1) If (IsMatch(n, "[\d.,-]")) Then ToNumber = ToNumber & n End If Next ToNumber = ToNumber * IIF(Left(argString, 1) = "(", -1, 1) End Function ' CreateRandomID - Create a random ID string (base 36) Public Function CreateRandomID(argLength) Dim EncodingChars(36), i, j ' Setup ... Randomize() CreateRandomID = "" ' Build encoding string from digits and letters ... For i = 0 To 9 EncodingChars(i) = CStr(i) Next For i = 0 To 25 EncodingChars(i + 10) = Chr(i + Asc("A")) Next For j = 1 To argLength CreateRandomID = CreateRandomID + EncodingChars(CInt(Rnd(1) * 35)) Next End Function ' ZeroFill() - Pad numbers to the left with argWidth digits Public Function ZeroFill(ByVal argNumber, ByVal argWidth) ZeroFill = argNumber Do While (Len(ZeroFill) < argWidth) ZeroFill = "0" & ZeroFill Loop End Function ' RoundCurrency() - Round Currency to the nearest whole (cent) Public Function RoundCurrency(ByVal argAmount) Dim RegEx If (Trim(argAmount) = "") Then RoundCurrency = FormatCurrency(0.00) Else Set RegEx = New RegExp RegEx.Pattern = "^[:d,.]" RegEx.Global = True RoundCurrency = FormatCurrency(RegEx.Replace(CStr(argAmount), "")) Set RegEx = Nothing End If End Function ' GetParms() - Extract parameters from ; delimited string ... Public Function GetParms(ByVal argParmString) Dim s s = argParmString If (Right(s, 1) = ";") Then s = Mid(s, 1, Len(s) - 1) End If GetParms = Split(s, ";") End Function ' GetParmToken() - Extract a specific token from a parm list (base 1) ... Public Function GetParmToken(ByVal argParmString, ByVal argTokenPosition, ByVal argDefaultValue) Dim TokenList, Position TokenList = Split(argParmString & ";", ";") Position = argTokenPosition - 1 Select Case True Case Position > UBound(TokenList) GetParmToken = "" Case strIsEmpty(TokenList(Position)) GetParmToken = Trim(argDefaultValue) Case Else GetParmToken = Trim(TokenList(Position)) End Select End Function ' catDisplayDDB() - Display categories in drop down box Public Sub catDisplayDDB() Dim rs, SQL, ReturnValue, Selected ' Display the category DDB ? If ((cstDisplayCategoryDDB = False) OR (cstCategoriesEnabled = False)) Then Exit Sub End If ' Check user exit for customized category display ... If (UserExit(usrDisplayCategoryDDB, Conn, 0, 0, 0, ReturnValue)) Then Exit Sub End If ' No user exit provided, proceed with standard category DDB ... SQL = "SELECT DISTINCT Category FROM CategoryIndex WHERE Hidden = 'No' ORDER BY Category" set rs = Server.CreateObject("ADODB.Recordset") rs.Open SQL, Conn, adOpenKeyset, adLockOptimistic ' Set up drop down box ... wl("") wl("  ") rs.Close : Set rs = Nothing End Sub ' File operations -------------------------------------------------------- ' DeleteFile() - Delete a file. ' - Returns FALSE if file exists and can't be deleted ... Public Function DeleteFile(ByVal argFileName) Dim FileObj On Error Resume Next If (FileExists(RootPath & argFileName)) Then Set FileObj = Server.CreateObject("Scripting.FileSystemObject") FileObj.DeleteFile RootPath & argFileName, False Set FileObj = Nothing ' Did it work? If (Not FileExists(RootPath & argFileName)) Then DeleteFile = True Else DeleteFile = False End If Else DeleteFile = True End If End Function ' MoveFile() - Move a file. ' - Returns FALSE if file exists and can't be moved ... Public Function MoveFile(ByVal argSrcFileName, ByVal argDestFileName) Dim FileObj On Error Resume Next If (FileExists(RootPath & argSrcFileName)) Then Set FileObj = Server.CreateObject("Scripting.FileSystemObject") FileObj.MoveFile RootPath & argSrcFileName, RootPath & argDestFileName Set FileObj = Nothing ' Did it work? If (Not FileExists(RootPath & argDestFileName)) Then MoveFile = True Else MoveFile = False End If Else MoveFile = True End If End Function ' ProtectInsertedData() - Protect data in SQL inserts with outside quotes and double interior ' - quotes. Public Function ProtectInsertedData(ByVal argInsertData) Dim i, c, s, t ' Double single quotes ... ProtectInsertedData = Replace(argInsertData, "'", "''") ' Replace unprintable characters with decimal equilvalents ... s = ProtectInsertedData : t = "" For i = 1 To Len(s) c = Mid(s, i, 1) If (c >= " " And c <= "~") Then t = t & c Else t = t & "' + Char(" & Asc(c) & ") + '" End If Next ' Enclose everything in quotes ... ProtectInsertedData = "'" & t & "'" End Function ' GetShortDescription() - Returns short product description ' - argDescriptionLong retained for symetry with GetLongDescription only. Public Function GetShortDescription(ByVal argDescription, ByVal argDescriptionLong) ' Protect against null strings coming from database ... GetShortDescription = CStr(argDescription & "") End Function ' GetLongDescription() - Returns long product description when available, ' - short description otherwise. Public Function GetLongDescription(ByVal argDescription, ByVal argDescriptionLong) Dim Description, DescriptionLong ' Protect against null strings coming from database ... Description = CStr(argDescription & "") DescriptionLong = CStr(argDescriptionLong & "") If ((cstLongDescriptionEnabled) AND (Trim(argDescriptionLong) <> "")) Then GetLongDescription = argDescriptionLong Else GetLongDescription = Description End If End Function ' Cart operations ------------------------------------------------------------- ' crtCreate() - Create the shopping cart if necessary Public Sub crtCreate() If (Not Session(sesCartCreate)) Then Session(sesShoppingCart) = aryCart Session(sesItemCount) = 0 Session(sesCartCreate) = True End If End Sub ' crtAddToCart() - Add item to shopping cart ... Public Sub crtAddToCart(argCartData) Dim i, AddComplete, Status, ReturnValue ' Make sure this item is not already in the cart ... AddComplete = False For i = 1 To iCount If ((Trim(aryCart(cartProductID, i)) = Trim(argCartData(cartProductID))) AND _ Trim((aryCart(cartOptions, i)) = Trim(argCartData(cartOptions)))) Then aryCart(cartItemQuantity, i) = aryCart(cartItemQuantity, i) + 1 aryCart(cartTotalPrice, i) = aryCart(cartUnitPrice, i) * _ aryCart(cartItemQuantity, i) AddComplete = True Exit For End If Next '************coded inserted august 28,2005**********start Dim ilar,jlar,klar,mlar If AddComplete then ilar=i klar=""& Request.ServerVariables("HTTP_REFERER") mlar="" if Right(klar,10)="larEdit=on" then For jlar=Len(klar)-11 to 1 Step -1 if IsNumeric(Mid(klar,jlar,1)) then mlar=Mid(klar,jlar,1) & mlar else Exit For end if Next if IsNumeric(mlar) then if int(mlar) <= iCount then if int(mlar)=int(ilar) then aryCart(larryNotes, ilar) = argCartData(larryNotes) aryCart(cartItemQuantity, ilar) = aryCart(cartItemQuantity, ilar) - 1 aryCart(cartTotalPrice, ilar) = aryCart(cartUnitPrice, ilar) * aryCart(cartItemQuantity, ilar) AddComplete =True else aryCart(cartItemQuantity, ilar) = aryCart(cartItemQuantity, ilar) - 1 aryCart(cartTotalPrice, ilar) = aryCart(cartUnitPrice, ilar) * aryCart(cartItemQuantity, ilar) aryCart(larryNotes, mlar) = argCartData(larryNotes) AddComplete =True end if end if end if elseif Trim(aryCart(larryNotes, ilar)) <> Trim(argCartData(larryNotes)) then AddComplete=false aryCart(cartItemQuantity, ilar) = aryCart(cartItemQuantity, ilar) - 1 aryCart(cartTotalPrice, ilar) = aryCart(cartUnitPrice, ilar) * aryCart(cartItemQuantity, ilar) end if end if '************coded inserted august 28,2005**********end If (Not AddComplete) Then If iCount < MaxShoppingCartItems Then iCount = iCount + 1 End if Session(sesItemCount) = iCount aryCart(cartProductID, iCount) = argCartData(cartProductID) aryCart(cartProductCode, iCount) = argCartData(cartProductCode) aryCart(cartProductName, iCount) = argCartData(cartProductName) aryCart(cartProductDescription, iCount) = argCartData(cartProductDescription) aryCart(cartProductDescriptionLong, iCount) = argCartData(cartProductDescriptionLong) aryCart(cartCategory, iCount) = argCartData(cartCategory) aryCart(cartCoupons, iCount) = argCartData(cartCoupons) aryCart(cartProductShipsFree, iCount) = argCartData(cartProductShipsFree) aryCart(cartShippingUnits, iCount) = argCartData(cartShippingUnits) aryCart(cartOptions, iCount) = argCartData(cartOptions) aryCart(cartUnitPrice, iCount) = argCartData(cartUnitPrice) aryCart(cartItemQuantity, iCount) = argCartData(cartItemQuantity) aryCart(cartMinQuantity, iCount) = argCartData(cartMinQuantity) aryCart(cartDiscountName, iCount) = argCartData(cartDiscountName) aryCart(cartDownloadFileName, iCount) = argCartData(cartDownloadFileName) aryCart(cartItemType, iCount) = argCartData(cartItemType) aryCart(cartAllowAmountEdit, iCount) = argCartData(cartAllowAmountEdit) aryCart(cartTaxOverride, iCount) = argCartData(cartTaxOverride) aryCart(cartNotes, iCount) = argCartData(cartNotes) aryCart(cartTotalPrice, iCount) = argCartData(cartUnitPrice) * _ argCartData(cartItemQuantity) aryCart(cartNSN, iCount) = argCartData(cartNSN) aryCart(cartPackaging, iCount) = argCartData(cartPackaging) aryCart(cartSKU, iCount) = argCartData(cartSKU) aryCart(larryNotes, iCount) = argCartData(larryNotes) End If ' Convert all NULL fields into zero-length strings... For i = 1 To ShoppingCartAttributes aryCart(i, iCount) = aryCart(i, iCount) & "" Next ' User exit for special pricing and quantity adjustment ... Status = UserExit(usrAdjustCart, Conn, 0, 0, 0, ReturnValue) Session(sesShoppingCart) = aryCart ' Register product code just added for subsequent cross sell recommendation ... If (IsInstalled("Feature:Cross Sell") AND cstCrossSellEnabled) Then If (argCartData(cartItemType) = "usr") Then FeatureInstalled("Feature:Cross Sell").ProductCode = argCartData(cartProductCode) End If End If End Sub ' SendEMail() - Send e-mail message using configured service and SMTP ... Public Sub SendEMail(ByVal argFromAddress, ByVal argToAddress, ByVal argSubject, ByVal argBody) Call SendEMailViaService(cstMailService, cstSMTPServer, argFromAddress, argToAddress, argSubject, argBody) End Sub ' SendEMailViaService() - Send e-mail message using specific service and SMTP ... Public Sub SendEMailViaService(ByVal argMailService, ByVal argSMTPServer, ByVal argFromAddress, ByVal argToAddress, ByVal argSubject, ByVal argBody) Dim objMail, objConf, Fields On Error Resume Next ' Fail quietly ... Select Case UCase(argMailService) Case "CDOSYS" Set objMail = CreateObject("CDO.Message") If (Not strIsEmpty(argSMTPServer)) Then Set objConf = CreateObject("CDO.Configuration") Set Fields = objConf.Fields Fields(cdoSendUsingMethod) = cdoSendUsingPort Fields(cdoSMTPServer) = argSMTPServer Fields(cdoSMTPServerPort) = 25 Fields(cdoSMTPAuthenticate) = cdoAnonymous Fields.Update Set ObjMail.Configuration = objConf End If With objMail .To = argToAddress .From = argFromAddress & " (" & cstCatalogName & ")" .Sender = argFromAddress & " (" & cstCatalogName & ")" .Subject = argSubject .TextBody = argBody .MimeFormatted = True .Send End With Set objConf = Nothing : Set Fields = Nothing : Set objConf = Nothing Case "CDONTS" set objMail = Server.CreateObject("CDONTS.NewMail") objMail.BodyFormat=1 ' Use MIME format. objMail.MailFormat=0 ' Use MIME formst. objMail.Send argFromAddress & " (" & cstCatalogName & ")", argToAddress, argSubject, argBody set objMail = Nothing Case "ASPMAIL" Set objMail = Server.CreateObject("SMTPsvg.Mailer") objMail.FromName = cstCatalogName objMail.FromAddress = argFromAddress objMail.RemoteHost = argSMTPServer objMail.TimeOut = 90 ' objMail.SMTPLog = "ASPMail.log" objMail.Subject = argSubject objMail.AddExtraHeader "Errors-To: " & cstErrorsToAddress objMail.ClearRecipients() objMail.AddRecipient "", argToAddress objMail.ClearBodyText() objMail.BodyText = argBody objMail.SendMail set objMail = Nothing Case "JMAIL" set objMail = Server.CreateObject("JMail.SMTPMail") objMail.ServerAddress = argSMTPServer objMail.Sender = argFromAddress objMail.SenderName = cstCatalogName objMail.Subject = argSubject objMail.Body = argBody objMail.AddRecipient argToAddress objMail.Execute set objMail = Nothing End Select End Sub ' CleanSQL() - Clear string of SQL injection hacks... Public Function CleanSQL(argString, argType) If (strIsEmpty(argString)) Then CleanSQL = "" Exit Function End If 'Clean up SQL If (LCase(argString) = "null") Then 'Nulls CleanSQL = Trim(argString) Else Select Case Trim(LCase(argType)) Case "i" : CleanSQL = CLng(argString) ' Int Case "d" : CleanSQL = CDbl(argString) ' Double Case Else CleanSQL = argString 'Alpha CleanSQL = Replace(CleanSQL, "--", " ") CleanSQL = Replace(CleanSQL, "==", " ") CleanSQL = Replace(CleanSQL, ";", " ") CleanSQL = Replace(CleanSQL, "'", "''") End Select End If End Function ' CleanString() - Remove problem characters from parm value string Public Function CleanString(ByVal argString) Dim i, s s = Trim(argString) For i = 1 To Len(s) Step 1 Select Case Mid(s, i, 1) Case Chr(10) CleanString = CleanString & " " Case Chr(13) CleanString = CleanString & " " Case "'", """" CleanString = CleanString & "" Case Else CleanString = CleanString & Mid(s, i, 1) End Select Next End Function ' DisplayJavaButton() - Display button on page with JavaScript action ... Public Sub DisplayJavaButton(ByVal argImageName, ByVal argAltName, ByVal argJavaScript) Response.Write("" & argAltName & "") End Sub ' isSQLServer() - Returns TRUE when running on a SQL server ... Public Function isSQLServer() isSQLServer = CBool((cstServerType <> "MSAccess")) End Function ' SessionContents() - Save or restore selected session variables in form variables. ' - Used to save session across transisition to secure server (SSL) ' - Protect double quotes (") by passing them as "~" Public Sub SessionContents(ByVal argMode) Dim aryTemp, iCount, SessionID, i, j Select Case argMode Case "save" aryTemp = Session(sesShoppingCart) For i = 1 To UBound(aryTemp, 1) For j = 1 To Session(sesItemCount) wl("") Next Next wl("") wl("") wl("") wl("") wl("") wl("") ' Preserve three reserved variables for user customization ... wl("") wl("") wl("") Case "restore" ' Restore only if session has been lost ... must be on other side of SSL ... If (Request.Form("Session-SessionID") <> "") Then SessionID = Request.Form("Session-SessionID") If (SessionID <> Session.SessionID) Then iCount = Request.Form("Session-ItemCount") Session(sesInit) = "True" Session(sesItemCount) = iCount Session(sesCustomerID) = CustomerID Session("ReturnTo") = Request.Form("Session-ReturnTo") Session("CartInPopUp") = Request.Form("Session-CartInPopUp") Session("REMOTE_ADDR") = Request.Form("Session-REMOTE_ADDR") Session("HTTP_ACCEPT_LANGUAGE") = Request.Form("Session-HTTP_ACCEPT_LANGUAGE") ' Recover reserved variables for user customization ... Session("UserVal1") = Request.Form("Session-UserVal1") Session("UserVal2") = Request.Form("Session-UserVal2") Session("UserVal3") = Request.Form("Session-UserVal3") For j = 1 To iCount For i = 1 To ShoppingCartAttributes aryCart(i, j) = Replace(Request.Form("Session-ShoppingCart-" & i & "-" & j), "~", """") Next Next Session(sesShoppingCart) = aryCart End If End If End Select End Sub ' Crypt() - EnCrypt/DeCrypt a string using the given key ... Function Crypt(ByVal argString, ByVal argKey, ByVal argMode) Select Case isTrialMode Case True : Crypt = argString Case False : Crypt = CryptString(argString, argKey, argMode) End Select End Function ' GreekCCNum() - Optionally "Greek" Credit Card Number Public Function GreekCCNum(ByVal argCCNum, ByVal argOptions) Dim Character, Length, CCNum, i, Force CCNum = Trim(argCCNum & "") Length = Len(CCNum) Force = CBool(InStr(argOptions, "f") <> 0) GreekCCNum = "" If (cstCCGreekEnabled Or Force) Then For i = 1 To Length Character = Mid(CCNum, i, 1) If ((IsNumeric(Character)) AND (i <= (Length - 4))) Then GreekCCNum = GreekCCNum & "*" Else GreekCCNum = GreekCCNum & Character End If Next Else GreekCCNum = argCCNum End If End Function ' FormatDateConst() - Format a date constant for Access or SQL ... Public Function FormatDateConst(ByVal argDate) If (cstServerType = "SQL") Then FormatDateConst = "'" & argDate & "'" Else FormatDateConst = "#" & argDate & "#" End If End Function ' isPrinterFriendly() - Returns TRUE if page is to be rendered without color ... Public Function isPrinterFriendly() isPrinterFriendly = CBool((InStr(LCase(Session("ReturnTo")), LCase("mOrdRev.asp")) <> 0) OR _ (GetURLValue("OrderID") <> "")) End Function ' InList() - Returns TRUE when arg is in comma separated list ... Public Function InList(ByVal argList, ByVal argValue) InList = CBool(InStr(argList & ",", argValue & ",") <> 0) End Function ' AddArray() - Append element to uni-dimensional array ... Public Sub AddArray(ByRef argArray, ByVal argValue) If (Not IsEmpty(argArray(0))) Then ReDim Preserve argArray(UBound(argArray) + 1) End If Select Case IsObject(argValue) Case True : Set argArray(UBound(argArray)) = argValue Case False : argArray(UBound(argArray)) = argValue End Select End Sub ' SortArray() - Sort the given array (case insensitive, zero based) Private Sub SortArray(ByRef arr, ByVal order) Dim pa, pb, temp, cnt cnt = UBound(arr) for pa = 0 to cnt - 1 for pb = 0 to cnt - pa - 1 Select Case UCase(order) Case "ASC" if LCase(arr(pb)) > LCase(arr(pb + 1)) then temp = arr(pb) arr(pb) = arr(pb + 1) arr(pb + 1) = temp end if Case "DESC" if LCase(arr(pb)) < LCase(arr(pb + 1)) then temp = arr(pb) arr(pb) = arr(pb + 1) arr(pb + 1) = temp end if End Select next next End Sub ' GoToURL - Go to new page ... Public Sub GoToURL(ByVal argURL) If (ServerIsIIS4) Then Response.Redirect(argURL) Else Server.Transfer(argURL) End If End Sub ' CreateHTTPObject() - Create and XMLHttp object using the best component ' - installed on this system ... Dim UsingHTTPObject ' For reference in mTest.asp Public Function CreateHTTPObject() On Error Resume Next Err.Clear UsingHTTPObject = "WinHTTP.WinHTTPRequest.5.1" Set CreateHTTPObject = Server.CreateObject(UsingHTTPObject) If (Err) Then Err.Clear UsingHTTPObject = "MSXML2.ServerXMLHTTP.3.0" Set CreateHTTPObject = Server.CreateObject(UsingHTTPObject) End If If (Err) Then Err.Clear UsingHTTPObject = "MSXML2.ServerXMLHTTP.4.0" Set CreateHTTPObject = Server.CreateObject(UsingHTTPObject) End If If (Err) Then Err.Clear UsingHTTPObject = "MSXML2.ServerXMLHTTP" Set CreateHTTPObject = Server.CreateObject(UsingHTTPObject) End If End Function ' isInstalled() - Returns True if the given feature is installed Public Function isInstalled(ByVal argFeatureName) isInstalled = isObject(FeatureInstalled(argFeatureName)) End Function ' isNullOrZero() - Returns True if the given argument is Null OR zero ... Public Function isNullOrZero(ByVal argValue) isNullOrZero = False If (IsNull(argValue)) Then isNullOrZero = True : Exit Function If (argValue = 0) Then isNullOrZero = True : Exit Function End Function ' GetCountryCode() - Look up a country's ISO code given on its name ... Public Function GetCountryCode(ByVal argCountryName, ByVal argFormat) Dim rs, SQL Set rs = Server.CreateObject("ADODB.Recordset") SQL = "SELECT * FROM Countries WHERE Name = '" & Replace(argCountryName & "", "'", "''") & "'" rs.Open SQL, Conn, adOpenKeyset, adLockOptimistic If (rs.RecordCount = 1) Then GetCountryCode = rs(argFormat) Else GetCountryCode = "" End If rs.close Set rs = Nothing End Function ' DisplayProductPrices() - Display Product List, Sale and Unit pricing ... Public Sub DisplayProductPrices(ByVal argRSProducts) Dim UseListPrice, UseSalePrice, MaxPrice, MinPrice, ws UseListPrice = cstListPriceEnabled AND (Not IsNullOrZero(argRSProducts("ListPrice"))) UseSalePrice = cstSalePriceEnabled AND (Not IsNullOrZero(argRSProducts("SalePrice"))) MaxPrice = argRSProducts("UnitPrice") MinPrice = argRSProducts("UnitPrice") fedprice = argRSProducts("UnitPrice") Set ws = New clsWS If (UseListPrice) Then MaxPrice = argRSProducts("ListPrice") ws("
List Price: " & OurFormatCurrency(argRSProducts("ListPrice")) & "") End If If (UseSalePrice) Then MinPrice = argRSProducts("SalePrice") ws("
Our Price: " & OurFormatCurrency(argRSProducts("UnitPrice")) & "") ws("
Sale Price: " & OurFormatCurrency(argRSProducts("SalePrice")) & "") Else Select Case session("Organization") Case "Federal" ws("
Federal Price: " & OurFormatCurrency(argRSProducts("FedSalePrice")) & "") Case "State" ws("
State Price: " & OurFormatCurrency(argRSProducts("StateSalePrice")) & "") Case "Local Government" ws("
Local Government Price: " & OurFormatCurrency(argRSProducts("LocalGovSalePrice")) & "") Case "Reseller" ws("
Reseller Price: " & OurFormatCurrency(argRSProducts("ResellerSalePrice")) & "") Case "Corporation" ws("
Corporation Price: " & OurFormatCurrency(argRSProducts("CorporationSalePrice")) & "") Case Else if (UseListPrice) Then ws("
Our Price: " & OurFormatCurrency(argRSProducts("UnitPrice")) & "") Else ws("
" & OurFormatCurrency(argRSProducts("UnitPrice")) & "") End If End Select End If If (cstSavingsDisplayEnabled) Then If ((MaxPrice - MinPrice) > 0) Then ws("
You Save: " & _ OurFormatCurrency(MaxPrice - MinPrice) & _ " (" & FormatPercent((CDbl(MaxPrice) - CDbl(MinPrice)) / CDbl(MaxPrice), 0, False, False, False) & ")") End If End If ' Drop initial
for clean embedd... wl(Mid(ws.Gets, 5)) End Sub ' GetUpgradeFileCRC() - Returns the last CRC for lib/upgrade.asp Public Function GetUpgradeFileCRC() Dim SQL, rs, dbConnection Set dbConnection = dbOpen("r") Set rs = Server.CreateObject("ADODB.Recordset") SQL = "SELECT * FROM Parms WHERE VariableName = 'cstUpgradeFileCRC'" rs.Open SQL, dbConnection, adOpenKeyset, adLockOptimistic If (rs.RecordCount = 1) Then GetUpgradeFileCRC = Trim(rs("Value")) Else GetUpgradeFileCRC = "" End If rs.Close : Set rs = Nothing dbClose(dbConnection) End Function ' isDatabaseCurrent() - Returns True if the underlying database matches this code release ... Public Function isDatabaseCurrent() ' Connect failed, bypass test this time ... If (ConnectFailed) Then isDatabaseCurrent = True Exit Function End If ' No test in free trial ... If (isTrialMode) Then isDatabaseCurrent = True OurSession("DatabaseOk") = True Exit Function End If ' Test once, remember on pass ... If (Not OurSession("DatabaseOk")) Then If (CStr(GetUpgradeFileCRC()) = CStr(GetCRC(ReadFile("\lib\upgrade.asp")))) Then OurSession("DatabaseOk") = True End If End If isDatabaseCurrent = OurSession("DatabaseOk") End Function ' DisplayAffiliateLink() - Optionally display affiliate link ... Public Sub DisplayAffiliateLink() Select Case LCase(cstAffiliateLink) Case "no" : ' Do nothing Case "yes" : wl("Shopping cart powered by safina eShop") Case Else : wl("Shopping cart powered by safina eShop") End Select End Sub ' DisplayStockStatus() - Display the current stocking level status for the product ' pointed to by the current record Set Public Sub DisplayStockStatus(ByVal argRS) Dim Display If (cstStockStatusEnabled And (Not strIsEmpty(argRS("StockStatus")))) Then wl("Status: " & argRS("StockStatus") & "") End If If (IsInstalled("Feature:Live Inventory") AND cstLiveInvEnabled) Then If (Not strIsEmpty(argRS("OnHandInv"))) Then Display = IIf(argRS("OnHandInv") <= 0, cstLiveInvNoStockDisplay, cstLiveInvInStockDisplay) ' Display stock level message ... wl("" & Replace(Display, "$(Count)", argRS("OnHandInv")) & "") End If End If End Sub ' GetURLValue() - Get value from URL line ... Public Function GetURLValue(ByVal argValueName) Dim Value Value = Request.QueryString(argValueName) GetURLValue = IIF(isMatch(Value, FormURLFilter), Value, "") End Function ' GetFormFieldValue() - Get value from form field ... Public Function GetFormFieldValue(ByVal argValueName) Dim Value Value = Trim(Request.Form(argValueName)) GetFormFieldValue = IIF(isMatch(Value, FormURLFilter), Value, "") End Function ' Clear CC Info() = Greek or delete cc info in database ... Public Sub ClearCCInfo(ByVal argRS) argRS("CreditCardNumber") = GreekCCNum(FormatCC(Crypt(argRS("CreditCardNumber"), cstEncryptionKey, "dec")), "f") argRS("CreditCardExpDate") = "**/**" argRS("CVV2") = "***" End Sub ' isFormPost() - Returns True if page load was due to a form post. (Portable method) Public Function isFormPost() isFormPost = CBool(Request.Form.Count <> 0) End Function ' isOnlineDemo() - Returns True if running in online demo mode ... Public Function isOnlineDemo(ByRef argErrorMsg) isOnlineDemo = FileExists(RootPath & "$OLDemo.flg") If (isOnlineDemo) Then argErrorMsg = argErrorMsg & "Feature disabled for online demo.
" End If End Function ' GetCRC() - Returns the CRC for the given string ... Public Function GetCRC(ByVal psString) Dim sValues, alCRCTable, lCRC, l sValues = "&h0,&h77073096,&hEE0E612C,&h990951BA,&h076DC419,&h706AF48F,&hE963A535,&h9E6495A3,&h0EDB8832,&h79DCB8A4,&hE0D5E91E,&h97D2D988,&h09B64C2B,&h7EB17CBD,&hE7B82D07,&h90BF1D91,&h1DB71064,&h6AB020F2,&hF3B97148,&h84BE41DE,&h1ADAD47D,&h6DDDE4EB,&hF4D4B551,&h83D385C7,&h136C9856,&h646BA8C0,&hFD62F97A,&h8A65C9EC,&h14015C4F,&h63066CD9,&hFA0F3D63,&h8D080DF5,&h3B6E20C8,&h4C69105E,&hD56041E4,&hA2677172,&h3C03E4D1,&h4B04D447," _ + "&hD20D85FD,&hA50AB56B,&h35B5A8FA,&h42B2986C,&hDBBBC9D6,&hACBCF940,&h32D86CE3,&h45DF5C75,&hDCD60DCF,&hABD13D59,&h26D930AC,&h51DE003A,&hC8D75180,&hBFD06116,&h21B4F4B5,&h56B3C423,&hCFBA9599,&hB8BDA50F,&h2802B89E,&h5F058808,&hC60CD9B2,&hB10BE924,&h2F6F7C87,&h58684C11,&hC1611DAB,&hB6662D3D,&h76DC4190,&h01DB7106,&h98D220BC,&hEFD5102A,&h71B18589,&h06B6B51F,&h9FBFE4A5,&hE8B8D433,&h7807C9A2,&h0F00F934,&h9609A88E,&hE10E9818," _ + "&h7F6A0DBB,&h086D3D2D,&h91646C97,&hE6635C01,&h6B6B51F4,&h1C6C6162,&h856530D8,&hF262004E,&h6C0695ED,&h1B01A57B,&h8208F4C1,&hF50FC457,&h65B0D9C6,&h12B7E950,&h8BBEB8EA,&hFCB9887C,&h62DD1DDF,&h15DA2D49,&h8CD37CF3,&hFBD44C65,&h4DB26158,&h3AB551CE,&hA3BC0074,&hD4BB30E2,&h4ADFA541,&h3DD895D7,&hA4D1C46D,&hD3D6F4FB,&h4369E96A,&h346ED9FC,&hAD678846,&hDA60B8D0,&h44042D73,&h33031DE5,&hAA0A4C5F,&hDD0D7CC9,&h5005713C,&h270241AA," _ + "&hBE0B1010,&hC90C2086,&h5768B525,&h206F85B3,&hB966D409,&hCE61E49F,&h5EDEF90E,&h29D9C998,&hB0D09822,&hC7D7A8B4,&h59B33D17,&h2EB40D81,&hB7BD5C3B,&hC0BA6CAD,&hEDB88320,&h9ABFB3B6,&h03B6E20C,&h74B1D29A,&hEAD54739,&h9DD277AF,&h04DB2615,&h73DC1683,&hE3630B12,&h94643B84,&h0D6D6A3E,&h7A6A5AA8,&hE40ECF0B,&h9309FF9D,&h0A00AE27,&h7D079EB1,&hF00F9344,&h8708A3D2,&h1E01F268,&h6906C2FE,&hF762575D,&h806567CB,&h196C3671,&h6E6B06E7," _ + "&hFED41B76,&h89D32BE0,&h10DA7A5A,&h67DD4ACC,&hF9B9DF6F,&h8EBEEFF9,&h17B7BE43,&h60B08ED5,&hD6D6A3E8,&hA1D1937E,&h38D8C2C4,&h4FDFF252,&hD1BB67F1,&hA6BC5767,&h3FB506DD,&h48B2364B,&hD80D2BDA,&hAF0A1B4C,&h36034AF6,&h41047A60,&hDF60EFC3,&hA867DF55,&h316E8EEF,&h4669BE79,&hCB61B38C,&hBC66831A,&h256FD2A0,&h5268E236,&hCC0C7795,&hBB0B4703,&h220216B9,&h5505262F,&hC5BA3BBE,&hB2BD0B28,&h2BB45A92,&h5CB36A04,&hC2D7FFA7,&hB5D0CF31," _ + "&h2CD99E8B,&h5BDEAE1D,&h9B64C2B0,&hEC63F226,&h756AA39C,&h026D930A,&h9C0906A9,&hEB0E363F,&h72076785,&h05005713,&h95BF4A82,&hE2B87A14,&h7BB12BAE,&h0CB61B38,&h92D28E9B,&hE5D5BE0D,&h7CDCEFB7,&h0BDBDF21,&h86D3D2D4,&hF1D4E242,&h68DDB3F8,&h1FDA836E,&h81BE16CD,&hF6B9265B,&h6FB077E1,&h18B74777,&h88085AE6,&hFF0F6A70,&h66063BCA,&h11010B5C,&h8F659EFF,&hF862AE69,&h616BFFD3,&h166CCF45,&hA00AE278,&hD70DD2EE,&h4E048354,&h3903B3C2," _ + "&hA7672661,&hD06016F7,&h4969474D,&h3E6E77DB,&hAED16A4A,&hD9D65ADC,&h40DF0B66,&h37D83BF0,&hA9BCAE53,&hDEBB9EC5,&h47B2CF7F,&h30B5FFE9,&hBDBDF21C,&hCABAC28A,&h53B39330,&h24B4A3A6,&hBAD03605,&hCDD70693,&h54DE5729,&h23D967BF,&hB3667A2E,&hC4614AB8,&h5D681B02,&h2A6F2B94,&hB40BBE37,&hC30C8EA1,&h5A05DF1B,&h2D02EF8D" alCRCTable = Split(sValues, ",") lCRC = &hFFFFFFFF For l = 1 To Len(psString) lCRC = alCRCTable(((lCRC And &hFFFF) Xor Asc(Mid(psString, l, 1))) And &hFF) Xor shr(lCRC, 8) Next ' l lCRC = lCRC Xor &hFFFFFFFF GetCRC = Trim(lCRC) End function ' shr() - Shift right by pbBits ' - Used by GetCRC() Public Function shr(plValue, pbBits) ' Shift bits to the right by pbBits shr = plValue \ (2 ^ pbBits) End Function ' clsWS - General purpose string "writing" class... Class clsWS Private mString ' Constructor ... Private Sub Class_Initialize() mString = "" End Sub ' Destructor ... Private Sub Class_Terminate() End Sub ' Public Methods ... Public Sub Clear() mString = "" End Sub Public Default Sub Write(ByVal argString) If (Not strIsEmpty(argString)) Then mString = mString & Trim(argString) & vbCrLf End If End Sub Public Function Gets() Gets = mString End Function End Class %>