<% '************************************************* '//Description: Formatting functions for manipulating data '//Copyright: Copyright©2005 Froya Ltd. '//Created: ??/??/05 Chris Cook '//Modified 03/10/05 Chris Cook - Rewrite of functions '************************************************* '-VAR 'Dim bDAllowed : bDAllowed = True 'Enables and Disables all debug functions '################################################# Function dServer(iOption) '//Process: Go through all of the server session variables and list them sReturn = "

HTTP & Server Variables:

" sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" For Each servervariable in request.servervariables 'don't display all and raw, these illw be listed anyhow If (servervariable <> "ALL_HTTP" AND servervariable <> "ALL_RAW") Then sReturn = sReturn & "" End If Next sReturn = sReturn & "
Server VariableField Value
 
" & servervariable & "" & request.servervariables(servervariable) & "
" d sReturn, iOption End Function '################################################# Function dSessionsSpecial(sStart, iOption) '//Process: Go through all of the session vars and list them On Error Resume Next sReturn = "

Session Variables:

" sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" '---List all sessions For Each oSession In Session.Contents() If (Mid(oSession,1,Len(sStart)) = sStart) Then 'display any array data If (IsArray(Session(oSession))) Then sReturn = sReturn & "" For iCount = LBound(Session(oSession)) to UBound(Session(oSession)) sReturn = sReturn & "" Next Else sReturn = sReturn & "" End If End If Next sReturn = sReturn & "
Session VariableField Value
 
" & oSession & "ARRAY:
(" & iCount & ")     :     " & Session(oSession)(iCount) & "
" & oSession & "" & Session.Contents(oSession) & "
" d sReturn, iOption End Function '################################################# Function dSessions(iOption) '//Process: Go through all of the session vars and list them On Error Resume Next sReturn = "

Session Variables:

" sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" '---List all sessions For Each oSession In Session.Contents() 'display any array data If (IsArray(Session(oSession))) Then sReturn = sReturn & "" For iCount = LBound(Session(oSession)) to UBound(Session(oSession)) sReturn = sReturn & "" Next Else sReturn = sReturn & "" End If Next sReturn = sReturn & "
Session VariableField Value
 
" & oSession & "ARRAY:
(" & iCount & ")     :     " & Session(oSession)(iCount) & "
" & oSession & "" & Session.Contents(oSession) & "
" d sReturn, iOption End Function '################################################# Function dForm(iOption) '//Process: List all items just submitted from a form (iEnd; 1=yes, 0=no) 'loop through all items and display them sReturn = "

Form Fields:

" sReturn = sReturn & "" sReturn = sReturn & "" For Each item In request.form sReturn = sReturn & "" Next sReturn = sReturn & "
Form FieldField Value
" & item & "" & request.form(item) & " 
" d sReturn, iOption End Function '################################################# Function dRS(oRS, iOption) '//Process: List a recordset and data sReturn = "

database RecordSet:

" sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" Do While Not (oRS.EOF) 'loop through records 'add the selection For Each field In oRS.Fields sReturn = sReturn & "" Next sReturn = sReturn & "" oRS.MoveNext 'next record Loop 'record set loop oRS sReturn = sReturn & "
Database FieldField ValueField Type
 
" & field.name & " " & field.value & " " & field.type & " 
 
" d sReturn, iOption End Function '################################################# Function dArray(aArray, iOption) '//Process: List the full field array and it's values sReturn = "

Array:

" sReturn = "" sReturn = sReturn & "" sReturn = sReturn & "" For i = 0 to uBound(aArray) sReturn = sReturn & "" If (aArray(i) <> "") Then aElement = Split(Replace(aArray(i),vbTab,""),",") If (InStr(aElement(1), "$") = 0)Then sReturn = sReturn & "" Else sReturn = sReturn & "" End If End If sReturn = sReturn & "" Next sReturn = sReturn & "
Database FieldForm Field ValueData TypeRequiredError Message
 
" & aElement(0) & "" & Request.Form(aElement(1)) & "" & aElement(2) & "" & aElement(3) & "" & aElement(4) & "" & aElement(0) & "" & StripVar(aElement(1), "", NULL) & "" & aElement(2) & "" & aElement(3) & "" & aElement(4) & "
" sReturn = sReturn & "
" d sReturn, iOption End Function '################################################# Function d(sString, iOption) '//Process: quick method for debugging scripts If (sString = "") Then sString = "(Null)" End If '-Check if allosed to execute If (bDAllowed) Then Select Case iOption Case 0 'write out string only Response.Write sString & "
" Case 1 'write out string and stop code Response.Write sString & "
" Response.End Case Else 'write out string only Response.Write sString End Select End If End Function '################################################# Function dTimerStart() '//Process: Start the timer by setting a session Session("debugTimer") = FormatDateTime(Now, vbLongTime) End Function '################################################# Function dTimerDisplay() '//Process: Display timer execution time d "Script Execution Time: " & DateDiff("s", Session("debugTimer"), FormatDateTime(Now, vbLongTime)) & " seconds", 0 End Function ''################################################# 'Function dItemDetails(item, sItem, iOption) ' '//Process: Go through all of the form item and display their details ' Response.Write "
Var: " & item & " Value: " & sItem & " Type: " & VarType(sItem) & "(" & TypeName(item) & ")" ' Response.Write "
Is Numeric: " & IsNumeric(sItem) ' Response.Write "
Is Date: " & IsDate(sItem) ''end response if needed 'If (iOption = 1) Then ' response.end 'End If 'End Function %> <% '************************************************** '//Script: FX Extension functions '//Copyright: 2004-2006 Froya Limited. All rights reserved. ' No part of this code maybe used or altered without prior permission of the owner '//Created: 08/09/2006 '//Modified: 14/09/2006 '************************************************** 'DEVELOPMENT NOTES ' - fx_formatExtTableName(sTable) NEEDS formatting_CreateLabel 'Requires ' inc_dbAccess.asp ' inc_dateTime.asp 'Global variables 'Session("systemSiteThemePath") 'theme path 'Session("systemCalendarPath") 'calendar path 'Session("systemFileSelectPath") 'file select path 'Function List ' fx_loadExtensions() ' fx_loadPermissions() ' fx_hasAccessPermission(sObjectType, sObjectRef, sPermissionType) ' fx_getExtensionValue(sTable, sField, iValue) ' fx_formatExtIsHidden(sTable, sField) ' fx_formatExtFieldSize(sTable, sField, iType) ' fx_getGroupField(sTable) ' fx_displayRecordActions(sTable) '################################################# Function fx_loadExtensions() '//Process: Load extensions into memory for quick access '//Return Session = oSystemPermission[userID][objType][objRef][Permission] '//Call: Call fx_LoadExtensions() '//Version: 1 '//Created: 08/09/2006 '//Modified:08/09/2006 '-VARS Dim oRSExt 'database connection Dim aExt(8) 'Array of extensions '-PROCESS On Error Resume Next 'We'll catch errors '-Open the recordset sSql = "SELECT [refTable], [refField], [refType], [isGroupField], [refParam1], [refParam2], [refParam3], [extTitle], [defaultValue] FROM [systemExtField] WHERE [isEnabled]=1;" Set oRSExt = DBOpenRS(oConn, sSql) 'save to Sessions If (Not oRSExt.EOF) Then '-Loop through any permissions Do While Not oRSExt.EOF aExt(0) = oRSExt("refTable") aExt(1) = oRSExt("refField") aExt(2) = oRSExt("refType") aExt(3) = oRSExt("isGroupField") aExt(4) = oRSExt("refParam1") aExt(5) = oRSExt("refParam2") aExt(6) = oRSExt("refParam3") aExt(7) = oRSExt("extTitle") aExt(8) = oRSExt("defaultValue") Session("fx_systemExtension[" & oRSExt("refTable") & "][" & oRSExt("refField") & "]") = aExt oRSExt.MoveNext Loop End If '-CLOSE Set oRSExt = Nothing End Function '################################################# Function fx_loadPermissions() '//Process: Load permissions into memory for quick access '//Return Session = oSystemPermission[userID][objType][objRef][Permission] '//Call: Call fx_LoadPermissions() '//Version: 1 '//Created: 08/09/2006 '//Modified:08/09/2006 '-VARS Dim oRSPermissions 'database connection '-PROCESS On Error Resume Next 'We'll catch errors 'Build sql and save each permission sSql = "SELECT DISTINCT * FROM [systemPermission] WHERE ((userID=" & Session("security_iUserID") & ") OR (userID=" & Session("security_iParentID") & "));" Set oRSPermissions = DBOpenRS(oConn, sSql) If (oRSPermissions.RecordCount <> 0) Then '-Loop through any permissions Do While Not oRSPermissions.EOF '-check each permission type and save to session Session("fx_systemPermission[" & oRSPermissions("objectType") & "][" & oRSPermissions("objectRef") & "][RC]") = oRSPermissions("RC") Session("fx_systemPermission[" & oRSPermissions("objectType") & "][" & oRSPermissions("objectRef") & "][WC]") = oRSPermissions("WC") Session("fx_systemPermission[" & oRSPermissions("objectType") & "][" & oRSPermissions("objectRef") & "][DC]") = oRSPermissions("DC") Session("fx_systemPermission[" & oRSPermissions("objectType") & "][" & oRSPermissions("objectRef") & "][RO]") = oRSPermissions("RO") Session("fx_systemPermission[" & oRSPermissions("objectType") & "][" & oRSPermissions("objectRef") & "][WO]") = oRSPermissions("WO") Session("fx_systemPermission[" & oRSPermissions("objectType") & "][" & oRSPermissions("objectRef") & "][DO]") = oRSPermissions("DO") ' Session("fx_systemPermission[" & oRSPermissions("objectType") & "][" & oRSPermissions("objectRef") & "][VS]") = oRSPermissions("VS") oRSPermissions.MoveNext Loop End If '-CLOSE Set oRSPermissions = Nothing End Function '################################################# Function fx_getExtensionData(sTable, sField, iElement) '//Process: Search the session array for Ext and return the element specified '//Param sTable = table reference ' sField = field reference ' iElement = element number to return '//Return: Element data or whole array if iElement = NULL '//Call: Call fx_LoadPermissions() '//Version: 1 '//Created: 14/09/2006 '//Modified:14/09/2006 'VARS Dim aExt 'Array of extensions Dim sReturn 'value to return '-PROCESS On Error Resume Next 'We'll handle errors '-Check if input is an array - * If (IsArray(Session("fx_systemExtension[*][*]"))) Then 'return default aExt = Session("fx_systemExtension[*][*]") 'load session into array '-Check what to return If (Not IsNULL(iElement)) Then sReturn = aExt(iElement) End If End If '-Check if input is an array - sTable | * If (IsArray(Session("fx_systemExtension[" & sTable & "][*]"))) Then 'sTable 'return specified aExt = Session("fx_systemExtension[" & sTable & "][*]") 'load session into array '-Check what to return If (Not IsNULL(iElement)) Then sReturn = aExt(iElement) End If End If '-Check if input is an array - * | sField If (IsArray(Session("fx_systemExtension[*][" & sField & "]"))) Then 'sTable 'return specified aExt = Session("fx_systemExtension[*][" & sField & "]") 'load session into array '-Check what to return If (Not IsNULL(iElement)) Then sReturn = aExt(iElement) End If End If '-Check if input is an array - sTable | sField If (IsArray(Session("fx_systemExtension[" & sTable & "][" & sField & "]"))) Then 'sTable 'return specified aExt = Session("fx_systemExtension[" & sTable & "][" & sField & "]") 'load session into array '-Check what to return If (Not IsNULL(iElement)) Then sReturn = aExt(iElement) End If End If '-RETURN '-Check what to return If (Not IsNULL(iElement)) Then fx_getExtensionData = sReturn Else fx_getExtensionData = aExt End If End Function '################################################# Function fx_hasAccessPermission(sObjectType, sObjectRef, sPermissionType) '//Process: Checks is the user has permission to access system resuorces with permission specified '//Param: sObjectType = type of object awaiting permission ' sObjectRef = the reference name of the object in question ' sPermissionType = type of permission VS RC WC DC RO WO DO '//Return: True/False '//Call: If (fx_hasAccessPermission(sObjectType, sObjectRef)) Then ... '//Version: 1 '//Created: 08/09/2006 '//Modified:08/09/2006 '-PROCESS 'check system permission If ((Session("fx_systemPermission[" & sObjectType & "][" & sObjectRef & "][" & sPermissionType & "]") = 1) Or (Session("fx_systemPermission[*][" & sObjectRef & "][" & sPermissionType & "]") = 1) Or (Session("fx_systemPermission[" & sObjectType & "][*][" & sPermissionType & "]") = 1) Or (Session("fx_systemPermission[*][*][" & sPermissionType & "]") = 1)) Then fx_hasAccessPermission = True Else fx_hasAccessPermission = false End If End Function '################################################# Function fx_getExtensionValue(sTable, sField, iValue) '//Process: get the extention value for a giev table/field/ref '//Param: sTable = table refence ' sField = field reference ' iValue = value of the ref to get '//Return: extension value '//Version: 1 '//Created: 14/09/2006 '//Modified:28/09/2006 '-VARS Dim sReturn '-PROCESS On Error Resume Next 'We'll handle errors If (Session("fx_systemExtension[*][*]")(iValue) <> "") Then sReturn = Session("fx_systemExtension[*][*]")(iValue) If (Session("fx_systemExtension[" & sTable & "][*]")(iValue) <> "") Then sReturn = Session("fx_systemExtension[" & sTable & "][*]")(iValue) If (Session("fx_systemExtension[*][" & sField & "]")(iValue) <> "") Then sReturn = Session("fx_systemExtension[*][" & sField & "]")(iValue) If (Session("fx_systemExtension[" & sTable & "][" & sField & "]")(iValue) <> "") Then sReturn = Session("fx_systemExtension[" & sTable & "][" & sField & "]")(iValue) 'check for null if name was asked for If ((IsEmpty(sReturn) Or IsNull(sReturn)) And (iValue = 7) And (sField <> "")) Then sReturn = sField 'return field raw If ((IsEmpty(sReturn) Or IsNull(sReturn)) And (iValue = 7) And (sField = "")) Then sReturn = sTable 'return table raw '-RETURN fx_getExtensionValue = sReturn End Function '################################################# Function fx_formatExtIsHidden(sTable, sField) '//Process: says if a hidden field '//Param: sTable = table refence ' sField = field reference '//Return: True/False '//Version: 1 '//Created: 14/09/2006 '//Modified:14/09/2006 'VARS Dim aExt 'Array of extensions Dim sReturn 'value to return On Error Resume Next 'We'll handle errors sReturn = fx_formatExtIsHidden(sTable, sField, 2) 'RETURN '-Check field If (sReturn = "Hidden") Then fx_formatExtIsHidden = True Else fx_formatExtIsHidden = False End If End Function '################################################# Function fx_formatExtFieldAttr(sTable, sField, iType, iReturn) '//Process: get the size of a field or it's type '//Param: sTable = table refence ' sField = field ' iType = type ' iReturn = return type size/field type [1:size, 2:type, 3:Description] '//Return: size of the field for the table '//Version: 1 '//Created: 14/09/2006 '//Modified:28/09/2006 '-VARS Dim aExt 'Array of extensions Dim sReturn1 : sReturn1 = 1 'value to return = size Dim sReturn2 : sReturn2 = "Text" 'value to return = type Dim sReturn3 : sReturn3 = "" 'value to return = description '-PROCESS On Error Resume Next 'We'll handle errors Select Case iType 'set sFieldType Case 3 'number-long integer sReturn1 = "2" sReturn2 = "Number" sReturn3 = "Long Integer" Case 17 'number-byte sReturn1 = "1" sReturn2 = "Number" sReturn3 = "Byte" Case 5 'number-double sReturn1 = "1" sReturn2 = "Number" sReturn3 = "Double" Case 202 'text sReturn1 = "3" sReturn2 = "Text" sReturn3 = "Text" Case 203 'memo sReturn1 = "5" sReturn2 = "Memo" sReturn3 = "Memo" Case 7 'date/time sReturn1 = "2" sReturn2 = "DateTime" sReturn3 = "Date/Time" ' Case 6 'currency ' sReturn1 = "2" ' sReturn2 = "Number" ' sReturn3 = "Currency" Case 11 'logical sReturn1 = "1" sReturn2 = "Logical" sReturn3 = "Logical" End Select 'iType Select Case fx_getExtensionValue(sTable, sField, 2) Case "Autonumber" sReturn1 = "1" sReturn2 = "Autonumber" sReturn3 = "Autonumber" Case "Currency" sReturn1 = "1" sReturn2 = "Currency" sReturn3 = "Currency" Case "Disabled" sReturn1 = "2" sReturn2 = "Disabled" sReturn3 = "Disabled" Case "Date" sReturn1 = "2" sReturn2 = "Date" sReturn3 = "Date" Case "DateTime" sReturn1 = "2" sReturn2 = "DateTime" sReturn3 = "Date/Time" Case "File" sReturn1 = "3" sReturn2 = "File" sReturn3 = "File Link" Case "Hidden" sReturn1 = "0" sReturn2 = "Hidden" sReturn3 = "Hidden" Case "HTML" sReturn1 = "5" sReturn2 = "HTML" sReturn3 = "HTML Allowed" Case "IDLog" sReturn1 = "1" sReturn2 = "IDLog" sReturn3 = "Sutonumber" Case "Lookup[menu]" sReturn1 = "2" sReturn2 = "Lookup[menu]" sReturn3 = "Selection Menu" Case "Lookup[radio]" sReturn1 = "2" sReturn2 = "Lookup[radio]" sReturn3 = "Choice Menu" Case "Lookup[table]" sReturn1 = "2" sReturn2 = "Lookup[table]" sReturn3 = "Table" Case "Password" sReturn1 = "2" sReturn2 = "Password" sReturn3 = "Password" Case "Read Only" sReturn1 = "2" sReturn2 = "Read Only" sReturn3 = "Read Only" Case "Relate" sReturn1 = "2" sReturn2 = "Relate" sReturn3 = "Table Relationship" Case "Time" sReturn1 = "2" sReturn2 = "Time" sReturn3 = "Time" Case "Link" sReturn1 = "2" sReturn2 = "Link" sReturn3 = "Email or Web link" Case "Logical" sReturn1 = "1" sReturn2 = "Logical" sReturn3 = "True/False" Case "Postcode[area]" sReturn1 = "2" sReturn2 = "Postcode" sReturn3 = "Postcode Lookup" Case "Int" sReturn1 = "1" sReturn2 = "Number" sReturn3 = "Number" End Select 'RETURN If (iReturn = 1) Then fx_formatExtFieldAttr = sReturn1 'size ElseIf (iReturn = 2) Then fx_formatExtFieldAttr = sReturn2 'type ElseIf (iReturn = 3) Then fx_formatExtFieldAttr = sReturn3 'description End If End Function '################################################# Function fx_getFormField(oConn, sTable, sField, sValue, iType, iReturn) '//Process: get a form field '//Param: oConn = DB connection ' sTable = table refence ' sField = field reference ' sValue = field value ' iType = field type ' iReturn = return type [1:form field, 2:list field] '//Return: form element '//Version: 1 '//Created: 27/09/2006 '//Modified:10/10/2006 'default value '-VARS Dim sReturn1 : sReturn1 = "" 'value to return for form input Dim sReturn2 : sReturn2 = "" 'value to return for list display Dim sType : sType = fx_formatExtFieldAttr(sTable, sField, iType, 2) 'field type Dim sParam1 : sParam1 = fx_getExtensionValue(sTable, sField, 4) 'get params Dim sParam2 : sParam2 = fx_getExtensionValue(sTable, sField, 5) 'get params Dim sParam3 : sParam3 = fx_getExtensionValue(sTable, sField, 6) 'get params Dim sRelateField : sRelateField = "" 'field to replate on Dim sRelateTable : sRelateTable = "" 'table to relate on Dim oRSLookup 'lookup recordset Dim oRSRelate 'relate table recordset '-PROCESS On Error Resume Next 'We'll handle errors 'check for form field If ((Request.Form(sField) <> "") And (Request.Form("action") <> "listRecords")) Then sValue = Request.Form(sField) End If Select Case LCase(sType) 'AUTONUMBER Case "autonumber": If ((sValue = "") Or (varType(sValue) = 1)) Then 'if empty the display auto number text sReturn1 = "(autonumber)" Else sReturn1 = sValue End If sReturn2 = sValue 'CURRENCY Case "currency": ' sReturn1 = "" sReturn1 = "" sReturn2 = "£" & FormatNumber(sValue,2,,,0) 'DATE Case "date": sReturn1 = "" sReturn1 = sReturn1 & "" sReturn2 = Mid(dateTimeConvert(sValue, sParam1),1,InStr(dateTimeConvert(sValue, sParam1)," ")-1) 'DATETIME Case "datetime": sReturn1 = "" sReturn1 = sReturn1 & "" sReturn2 = dateTimeConvert(sValue, sParam1) 'DISABLED Case "disabled": sReturn1 = "" sReturn2 = sValue 'FILE Case "file": 'create input elements sReturn1 = "" sReturn1 = sReturn1 & "" sReturn1 = sReturn1 & "" sReturn2 = "" & sValue & "" 'HIDDEN Case "hidden": sReturn1 = "" sReturn2 = "" 'HTML Case "html": 'check for speech char If (sValue <> "") Then 'is not empty sValue = Replace(sValue, """", """) 'replace "(speech) with hex alternative End If sReturn1 = "" sReturn1 = sReturn1 & "" sReturn2 = Mid(sValue, 1, fx_getExtensionData(sTable, sField, 4)) sReturn2 = stringManip_HTMLSafe(sReturn2) 'IDLog Case "idlog": If ((iReturn=1) And (sValue="")) Then iNewID = dbNewID(oConn, sField) Else iNewID = sValue 'keep current value to return End If 'check display option sReturn1 = "" If (sParam1 = "1") Then sReturn1 = sReturn1 & "" & iNewID & "" End If sReturn2 = sValue 'LINK Case "link": 'check for speech char If (sValue <> "") Then 'is not empty sValue = Replace(sValue, """", """) 'replace "(speech) with hex alternative End If 'create imput element sReturn1 = "" sReturn2 = "" & sValue & "" 'LOGICAL Case "logical": 'create input element sReturn1 = "" Else sReturn2 = "" End If sReturn1 = sReturn1 & "/>" 'MENU LOOKUP Case "lookup[menu]": 'open recordset sSql = "SELECT [value] FROM [systemLookup] WHERE ([category]='" & sParam1 & "');" 'check for order by If (sParam2 = "1") Then sSql = Replace(sSql, ";", " ORDER BY [value] ASC;") End If Set oRSLookup = dbOpenRS(oConn, sSql) 'create select element sReturn1 = "" Set oRSLookup = Nothing 'close rs sReturn2 = sValue 'RADIO LOOKUP Case "lookup[radio]": 'open recordset sSql = "SELECT [value] FROM [systemLookup] WHERE ([category]='" & sParam1 & "') ORDER BY [value] ASC;" Set oRSLookup = dbOpenRS(oConn, sSql) 'create input element sReturn1 = " None
" Do While Not oRSLookup.EOF 'loop records sReturn1 = sReturn1 & " " sReturn1 = sReturn1 & oRSLookup("value") & "
" oRSLookup.MoveNext Loop Set oRSLookup = Nothing 'close rs sReturn2 = sValue 'TABLE LOOKUP Case "lookup[table]": 'open recordset Set oRSLookup = dbOpenSchema(oConn, 20, Array(Empty, Empty, Empty, "TABLE")) 'create select element sReturn1 = "" Set oRSLookup = Nothing 'close rs sReturn2 = sValue 'TIME Case "time": sReturn1 = "" sReturn2 = Mid(dateTimeConvert(sValue, sParam1),InStr(dateTimeConvert(sValue, sParam1)," ")+1) 'MEMO Case "memo": If (sValue <> "") Then 'is not empty sValue = Replace(sValue, """", """) 'replace "(speech) with hex alternative End If sReturn1 = "" 'check memo display length set If (IsNumeric(fx_getExtensionValue(sTable, sField, 4)) And Not IsEmpty(fx_getExtensionValue(sTable, sField, 4))) Then sReturn2 = Mid(sValue, 1, fx_getExtensionValue(sTable, sField, 4)) Else sReturn2 = sValue End If 'NUMBER Case "number": sReturn1 = "" sReturn2 = sValue 'PASSWORD Case "password": sReturn1 = "" For i = 1 To Len(sValue) sReturn2 = sReturn2 & "*" Next 'POSTCODE Case "postcode": sReturn1 = "" sReturn2 = sValue 'READ ONLY Case "read only": sReturn1 = sValue sReturn2 = sValue 'RELATE Case "relate": 'check reference table containing table and field If (InStr(sParam1, ".") > 0) then 'contains table and field sRelateField = Mid(sParam1, InStr(sParam1, ".")+1) sRelateTable = Mid(sParam1, 1, InStr(sParam1, ".")-1) Else 'assume field is ID sRelateField = "ID" sRelateTable = sParam1 End If 'create query sSql = "SELECT " & sRelateField & ", " 'begin query sSql = sSql & "[" & Trim(sParam2) & "], " sSql = Left(sSql, Len(sSql)-2) 'rem extra ,(comma) sSql = sSql & " FROM " & sRelateTable If (sParam3 <> "") Then sSql = sSql & " WHERE " & sParam3 End If sSql = sSql & ";" 'end query 'execute query Set oRSRelate = dbOpenRS(oConn, sSql) 'create select element sReturn1 = "" Set oRSRelate = Nothing 'close rs 'TEXT Case Else: sReturn1 = "" sReturn2 = sValue End Select '-RETURN If (iReturn = 1) Then fx_getFormField = sReturn1 'form ElseIf (iReturn = 2) Then fx_getFormField = sReturn2 'list End If End Function '################################################## Function fx_getGroupField(oConn, sTable) '//Process: get the group field for a given table '//Param: oConn : database connection ' sTable : table to get the group field for '//Return: field name or null ("") '//Call: sGroupField = fx_getGroupField(oConn, "sTableName") '//Version: 1 '//Created: 18/09/2006 '//Modified:18/09/2006 '-VARS Dim sGroupField : sGroupField = "" Dim oRSFields '-PROCESS 'check if table exists If (dbTableExists(sTable, oConn)) Then 'Get all fields in table sSql = "SELECT TOP 1 * FROM [" & sTable & "];" Set oRSFields = dbOpenRS(oConn, sSql) If (Not oRSFields.EOF) Then For i=0 to oRSFields.Fields.Count-1 If (fx_getExtensionValue(sTable, oRSFields(i).Name, 3) = 1) Then 'check if group 'save group field sGroupField = oRSFields(i).Name 'end loop as only allowed one group i = oRSFields.Fields.Count End If Next 'field End If 'record returned check End If 'doesn't exist Set oRSFields = Nothing '-RETURN fx_getGroupField = sGroupField End Function '################################################## Function fx_displayRecordActions(sTable, oRS) '//Process: display the FX actions associated with a record '//Param: sTable = matching table for the action ' oRS = current record '//Return: rendered actions '//Call: sReturn = fx_displayRecordActions(a,b,c) '//Version: 1 '//Created: 09/11/2006 '//Modified:09/11/2006 '-VARS Dim sReturn : sReturn = "" '-PROCESS If (fx_getExtensionValue(sTable, "SDAAction", 2) = "OpenTable") Then 'open relation action sReturn = sReturn & VbTab & vbTab & "" & VbCrLF 'open relation End If If (fx_getExtensionValue(sTable, "SDAAction", 2) = "OpenRecord") Then 'open relation action sReturn = sReturn & VbTab & vbTab & "" & VbCrLF 'open relation End If If (fx_getExtensionValue(sTable, "SDAAction", 2) = "OpenLink") Then 'open relation action sReturn = sReturn & VbTab & vbTab & "" & VbCrLF 'open relation End If If (fx_getExtensionValue(sTable, "SDAAction", 2) = "Function") Then 'open relation action sReturn = sReturn & VbTab & vbTab & "" & VbCrLF 'open relation End If '-RETURN fx_displayRecordActions = sReturn End Function %> <% '************************************************** '//Script: user security and login management '//Copyright: 2004-2006 Froya Limited. All rights reserved. ' No part of this code maybe used or altered without prior permission of the owner '//Created: '//Modified: '************************************************** 'Requires ' login.asp ' inc_dbAccess.asp '-Global Variables ' Session("systemLoginScript") = "login.asp" 'security login path ' security_bDomainLogin : True/False 'Function List ' security_displayLogonForm() ' security_validateUser() ' security_performLogin() '################################################# '-ADJUSTABLE FUNCTION Function security_onLogin() Call fx_loadPermissions() Call fx_loadExtensions() End Function '################################################# '-ADJUSTABLE FUNCTION Function security_onLogout() Session.Abandon() End Function '################################################# Function security_displayLogonForm() '//Process: Generate the login form for the fx login system Dim sReturn : sReturn = "" sReturn = sReturn & "
" sReturn = sReturn & "" sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & "
Username
Password
" sreturn = sReturn & " " sreturn = sReturn & " " sreturn = sReturn & "
" sReturn = sReturn & "
" security_displayLogonForm = sReturn End Function '################################################## Function security_validateUser() '//Process: Validate a user login '//Return: if false login -> redirect to login.asp '//Call: Call security_validateUser() '//Version: 1 '//Created: 07/09/2006 '//Modified:07/09/2006 '-VARS Dim iUserID '-PROCESS iUserID = Session("security_iUserID") 'Check Code Session If ((Not IsNumeric(iUserID)) Or (iUserID = "")) Then 'check for auto login If (security_bDomainLogin) Then 'validate login ' Call security_performLogin() If (Not security_performLogin()) Then 'invalid logon Response.Redirect Session("systemLoginScript") End If Else 'invalid Response.Redirect Session("systemLoginScript") End If End If End Function '################################################## Function security_performLogin() '//Process: Perform the system login and set the appropriate session variables for the fx login system '//Return: True/False '//Call: If (security_performLogin) Then ... '//Version: 1 '//Created: 07/09/2006 '//Modified:07/09/2006 '-VARS Dim oRSTemp 'database connection Dim sSql : sSql = "" 'holds sql statement '-PROCESS 'generate SQL If ((Request.Form("username") <> "") And (Request.Form("password") <> "")) Then sSql = "SELECT DISTINCT ID, displayName, username, email, parentID " sSql = sSql & "FROM [systemUser] " sSql = sSql & "WHERE (username='" & Replace(Request.Form("username"),"'","''") & "') AND (password='" & Replace(Request.Form("password"),"'","''") & "') AND (isEnabled=1) AND (isGroup=0);" ElseIf (security_bDomainLogin) Then sSql = "SELECT DISTINCT ID, displayName, username, email, parentID " sSql = sSql & "FROM [systemUser] " sSql = sSql & "WHERE (username='" & Replace(Request.ServerVariables("LOGON_USER"),"'","''") & "') AND (isEnabled=1) AND (isGroup=0);" End If If (sSql <> "") Then 'query database and open recordset ' Set oConn = dbOpenConn(G_DATABASE_NAME) Set oRSTemp = dbOpenRS(oConn, sSql) If (Not (oRSTemp.EOF)) Then 'logged in okay, set sessions and code Session("security_iUserID") = oRSTemp("ID") Session("security_sDisplayName") = oRSTemp("displayName") Session("security_sUsername") = oRSTemp("username") Session("security_sEmail") = oRSTemp("email") Session("security_iParentID") = oRSTemp("parentID") Call security_onLogin() 'message of success Call messageTrap("Successful Login") security_performLogin = True Else 'invalid login Call messageTrap("Invalid credentials, please try again") security_performLogin = False End If Else 'invalid login Call messageTrap("Invalid credentials, please try again") security_performLogin = False End If Set oRS = Nothing End Function '################################################## Function security_performLogout() '//Process: Perform the system logout '//Return: True/False '//Call: security_performLogout '//Version: 1 '//Created: 08/09/2006 '//Modified:08/09/2006 Session("security_iUserID") = "" Session("security_sDisplayName") = "" Session("security_sUsername") = "" Session("security_sEmail") = "" Session("security_iParentID") = "" Call security_onLogout() End Function %> <% '************************************************** '//Script: SDA - Simple Database Admin Component '//Copyright: 2004-2006 Froya Limited. All rights reserved. ' No part of this code maybe used or altered without prior permission of the owner '//Created: 06/09/2006 CC '//Modified: 06/09/2006 CC '************************************************** server.ScriptTimeout = 2 'NOTES ' - inc_sda_TEST/ <- replace with assets dir variable 'Requires ' inc_dbAccess.asp or inc_dbMsSQL ' inc_security.asp ' inc_fx.asp ' inc_errors.asp 'Function List '-VARIABLES Dim sdaRecordsPerPage : sdaRecordsPerPage = 25 '################################################## Function sda_listTables() '//Process: List viewable tables '//Return: Table with database tables listed '//Call: response.write sdaListTables() '//Version: 1 '//Created: 07/09/2006 '//Modified:07/09/2006 '-VARS Dim oRS Dim sReturn : sReturn = "" '-PROCESS sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" Set oRS = dbOpenSchema(oConn, 20, Array(Empty, Empty, Empty, "TABLE")) iCount = 0 Do While Not oRS.EOF sTableName = oRS("table_name") ' 'check if user allowed to read and/or edit table bUserAllowedRead = fx_hasAccessPermission("table", sTableName, "RC") If (Not(bUserAllowedRead)) Then 'if the table is a system table and the user is an administrator then show it 'hide table Else sReturn = sReturn & "" If (Mid(sTableName, 1, 6) = "system") Then sReturn = sReturn & "" Else sReturn = sReturn & "" End If sReturn = sReturn & "" sReturn = sReturn & "" iCount = iCount + 1 End If oRS.MoveNext Loop 'oRS If (iCount = 0) Then sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" End If sReturn = sReturn & "" sReturn = sReturn & "
Tables
" sReturn = sReturn & "
" sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & "
" sReturn = sReturn & "		" sReturn = sReturn & "
" sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & "
" sReturn = sReturn & "		" & stringManip_createLabel(fx_getExtensionValue(sTableName, "", 7)) & "
" sReturn = sReturn & "" & fx_getExtensionValue(sTableName, "", 4) & "
" sReturn = sReturn & "There are not tables to display
" '-tidy oRS.Close() Set oRS = nothing '-RETURN sda_listTables = sReturn End Function '################################################## Function sda_listViews() '//Process: List viewable views '//Return: Table with database views listed '//Call: response.write sdaListViews() '//Version: 1 '//Created: 03/11/2006 '//Modified:03/11/2006 '-VARS Dim oRS Dim sReturn : sReturn = "" '-PROCESS sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" Set oRS = dbOpenSchema(oConn, 20, Array(Empty, Empty, Empty, "VIEW")) iCount = 0 Do While Not oRS.EOF sTableName = oRS("table_name") ' 'check if user allowed to read and/or edit table bUserAllowedRead = fx_hasAccessPermission("view", sTableName, "RC") If (Not(bUserAllowedRead)) Then 'if the table is a system table and the user is an administrator then show it 'hide table Else sReturn = sReturn & "" If (Mid(sTableName, 1, 6) = "system") Then sReturn = sReturn & "" Else sReturn = sReturn & "" End If sReturn = sReturn & "" sReturn = sReturn & "" iCount = iCount + 1 End If oRS.MoveNext Loop 'oRS If (iCount = 0) Then sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" End If sReturn = sReturn & "" sReturn = sReturn & "
Views
" sReturn = sReturn & "
" sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & "
" sReturn = sReturn & "		" sReturn = sReturn & "
" sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & "
" sReturn = sReturn & "		" & stringManip_createLabel(fx_getExtensionValue(sTableName, "", 7)) & "
" sReturn = sReturn & "" & fx_getExtensionValue(sTableName, "", 4) & "
" sReturn = sReturn & "There are not tables to display
" '-tidy oRS.Close() Set oRS = nothing '-RETURN sda_listViews = sReturn End Function '################################################# Function sda_loadSystemPermissions(oConn) '//Process: Load permissions into memory for quick access '//Param: oConn = database connection '//Return: Session = oSystemPermission[userID][objType][objRef][Permission] '//Call: Call sda_loadSystemPermissions(oConn) '//Version: 1 '//Created: 07/09/2006 '//Modified:07/09/2006 '-PROCESS '-Build each SQL and save each permission sSql = "SELECT DISTINCT * FROM [systemPermission] WHERE ((userID=" & Session("systemUserID") & ") OR (userID=" & Session("systemUserParentID") & "));" Set oRSPermissions = DBOpenRS(oConn, sSql) If (oRSPermissions.RecordCount <> 0) Then '-Loop through any permissions Do While Not oRSPermissions.EOF '-check each permission type and save to session Session("oSystemPermission[" & oRSPermissions("objectType") & "][" & oRSPermissions("objectRef") & "][A]") = oRSPermissions("A") Session("oSystemPermission[" & oRSPermissions("objectType") & "][" & oRSPermissions("objectRef") & "][RC]") = oRSPermissions("RC") Session("oSystemPermission[" & oRSPermissions("objectType") & "][" & oRSPermissions("objectRef") & "][WC]") = oRSPermissions("WC") Session("oSystemPermission[" & oRSPermissions("objectType") & "][" & oRSPermissions("objectRef") & "][DC]") = oRSPermissions("DC") Session("oSystemPermission[" & oRSPermissions("objectType") & "][" & oRSPermissions("objectRef") & "][RO]") = oRSPermissions("RO") Session("oSystemPermission[" & oRSPermissions("objectType") & "][" & oRSPermissions("objectRef") & "][WO]") = oRSPermissions("WO") Session("oSystemPermission[" & oRSPermissions("objectType") & "][" & oRSPermissions("objectRef") & "][DO]") = oRSPermissions("DO") Session("oSystemPermission[" & oRSPermissions("objectType") & "][" & oRSPermissions("objectRef") & "][VS]") = oRSPermissions("VS") oRSPermissions.MoveNext Loop End If Set oRSPermissions = Nothing End Function '################################################## Function sda_getRecordset(oConn, sTable, sSearch, sSortField, sSortDirection, iPage) '//Process: Geberate a recirdset with the correct sorting and filetring for SDA '//Param: oConn : database connection ' sTable : table to get data for ' sSearch : search criteria ' sSortField : field to sort results by ' sSortDirection : direction to sort in ' iPage : current page number of results '//Return: Recordset '//Call: Set oRS = sda_getRecordset("products","","","","",2) '//Version: 1 '//Created: 18/09/2006 '//Modified:18/09/2006 '-VARS Dim oRS : Set oRS = Nothing Dim oRSFields : Set oRSFields = Nothing Dim sSql : sSql = "" 'holds SQL strings Dim sSqlFilter : sSqlFilter = "" 'build search SQL filter Dim sSqlOrder : sSqlOrder = "" 'build search SQL order Dim sGroupField : sGroupField = "" 'hodls the field to group on Dim iFieldCount : iFieldCount = 0 'the number of fields in the table '-PROCESS 'check if table exists If (dbTableExists(sTable, oConn)) Then 'table exists 'Get all fields in table sSql = "SELECT TOP 1 * FROM [" & sTable & "];" Set oRSFields = dbOpenRS(oConn, sSql) If (Not oRSFields.EOF) Then 'SELECT sSql = "SELECT " 'get number of fields returned iFieldCount = oRSFields.Fields.Count 'analyse the fields For i=0 to iFieldCount-1 If (fx_getExtensionValue(sTable, oRSFields(i).Name, 2) = "Hidden") Then 'check if hidden Else sSql = sSql & "[" & oRSFields(i).Name & "], " End If Next 'field sSql = Mid(sSql, 1, Len(sSql)-2) 'FROM sSql = sSql & " FROM [" & sTable & "] " 'Open recordset Set oRS = dbOpenRS(oConn, sSql) 'Check for returned data If (Not oRS.EOF) Then 'apply FILTER If (sSearchCriteria <> "") Then sSearchCriteria = Replace(sSearchCriteria,"'","''") 'fix string 'add to each non-hidden record For i=0 to iFieldCount-1 If (fx_getExtensionValue(sTable, oRSFields(i).Name, 2) = "Hidden") Then 'check if hidden Else aSearchCriteria = Split(sSearchCriteria, " ") 'split spaces into array 'build filter For i2=0 To Ubound(aSearchCriteria) If ((oRSFields(i).Type = 202) OR (oRSFields(i).Type = 203) OR (oRSFields(i).Type = 7)) Then 'if string sSqlFilter = sSqlFilter & "([" & oRSFields(i).Name & "] LIKE '%" & Trim(aSearchCriteria(i2)) & "%') OR " ElseIf (IsNumeric(Trim(aSearchCriteria(i2)))) Then 'if numeric sSqlFilter = sSqlFilter & "([" & oRSFields(i).Name & "] LIKE %" & Trim(aSearchCriteria(i2)) & "%) OR " End If Next 'APPLY FILTER If (sSqlFilter <> "") Then On Error Resume Next oRS.Filter = Mid(sSqlFilter, 1, Len(sSqlFilter)-4) End If End If Next 'field End If 'search criteria given 'apply SORT / GROUP 'analyse the fields for a group field For i=0 to iFieldCount-1 If (fx_getExtensionValue(sTable, oRSFields(i).Name, 3) = 1) Then 'check if group 'add order for group If ((sSortField = oRSFields(i).Name) AND sSortDirection = "desc") Then 'check if set as a sort and what direction sSqlOrder = sSqlOrder & "[" & oRSFields(i).Name & "] DESC, " Else sSqlOrder = sSqlOrder & "[" & oRSFields(i).Name & "] ASC, " End If 'save group field sGroupField = oRSFields(i).Name 'end loop as only allowed one group i = iFieldCount End If Next 'field If (sSqlOrder <> "") Then sSqlOrder = Mid(sSqlOrder, 1, Len(sSqlOrder)-2) 'trim if something to trim 'check for sort field click If ((sSortField <> "") And (sSortField <> sGroupField) And (sSqlOrder <> "")) Then 'add sort to existing sSqlOrder = sSqlOrder & ", [" & sSortField & "] " & sSortDirection ElseIf ((sSortField <> "") And (sSortField <> sGroupField) And (sSqlOrder = "")) Then 'make new sort sSqlOrder = "[" & sSortField & "] " & sSortDirection End If 'apply the sort of it's there oRS.Sort = sSqlOrder 'apply PAGING 'get page number If (IsEmpty(iPage) Or IsNull(iPage)) Then iPage = 1 'default oRS.PageSize = sdaRecordsPerPage oRS.AbsolutePage = iPage End If 'oRS.EOF End If 'oRS Fields.EOF End If 'table exists '-RETURN Set sda_getRecordset = oRS Set oRS = Nothing Set oRSFields = Nothing End Function '################################################## Function a() '//Process: '//Param: '//Return: '//Call: '//Version: '//Created: '//Changes: '//Modified: '//Updates: '-VARS '-PROCESS '-RETURN End Function %> [an error occurred while processing this directive] <% '************************************************** '//Script: user security and login management '//Copyright: 2004-2006 Froya Limited. All rights reserved. ' No part of this code maybe used or altered without prior permission of the owner '//Created: '//Modified: '************************************************** 'Requires ' login.asp ' inc_dbAccess.asp '-Global Variables ' Session("systemLoginScript") = "login.asp" 'security login path ' security_bDomainLogin : True/False 'Function List ' security_displayLogonForm() ' security_validateUser() ' security_performLogin() '################################################# '-ADJUSTABLE FUNCTION Function security_onLogin() Call fx_loadPermissions() Call fx_loadExtensions() End Function '################################################# '-ADJUSTABLE FUNCTION Function security_onLogout() Session.Abandon() End Function '################################################# Function security_displayLogonForm() '//Process: Generate the login form for the fx login system Dim sReturn : sReturn = "" sReturn = sReturn & "
" sReturn = sReturn & "" sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & " " sReturn = sReturn & "
Username
Password
" sreturn = sReturn & " " sreturn = sReturn & " " sreturn = sReturn & "
" sReturn = sReturn & "
" security_displayLogonForm = sReturn End Function '################################################## Function security_validateUser() '//Process: Validate a user login '//Return: if false login -> redirect to login.asp '//Call: Call security_validateUser() '//Version: 1 '//Created: 07/09/2006 '//Modified:07/09/2006 '-VARS Dim iUserID '-PROCESS iUserID = Session("security_iUserID") 'Check Code Session If ((Not IsNumeric(iUserID)) Or (iUserID = "")) Then 'check for auto login If (security_bDomainLogin) Then 'validate login ' Call security_performLogin() If (Not security_performLogin()) Then 'invalid logon Response.Redirect Session("systemLoginScript") End If Else 'invalid Response.Redirect Session("systemLoginScript") End If End If End Function '################################################## Function security_performLogin() '//Process: Perform the system login and set the appropriate session variables for the fx login system '//Return: True/False '//Call: If (security_performLogin) Then ... '//Version: 1 '//Created: 07/09/2006 '//Modified:07/09/2006 '-VARS Dim oRSTemp 'database connection Dim sSql : sSql = "" 'holds sql statement '-PROCESS 'generate SQL If ((Request.Form("username") <> "") And (Request.Form("password") <> "")) Then sSql = "SELECT DISTINCT ID, displayName, username, email, parentID " sSql = sSql & "FROM [systemUser] " sSql = sSql & "WHERE (username='" & Replace(Request.Form("username"),"'","''") & "') AND (password='" & Replace(Request.Form("password"),"'","''") & "') AND (isEnabled=1) AND (isGroup=0);" ElseIf (security_bDomainLogin) Then sSql = "SELECT DISTINCT ID, displayName, username, email, parentID " sSql = sSql & "FROM [systemUser] " sSql = sSql & "WHERE (username='" & Replace(Request.ServerVariables("LOGON_USER"),"'","''") & "') AND (isEnabled=1) AND (isGroup=0);" End If If (sSql <> "") Then 'query database and open recordset ' Set oConn = dbOpenConn(G_DATABASE_NAME) Set oRSTemp = dbOpenRS(oConn, sSql) If (Not (oRSTemp.EOF)) Then 'logged in okay, set sessions and code Session("security_iUserID") = oRSTemp("ID") Session("security_sDisplayName") = oRSTemp("displayName") Session("security_sUsername") = oRSTemp("username") Session("security_sEmail") = oRSTemp("email") Session("security_iParentID") = oRSTemp("parentID") Call security_onLogin() 'message of success Call messageTrap("Successful Login") security_performLogin = True Else 'invalid login Call messageTrap("Invalid credentials, please try again") security_performLogin = False End If Else 'invalid login Call messageTrap("Invalid credentials, please try again") security_performLogin = False End If Set oRS = Nothing End Function '################################################## Function security_performLogout() '//Process: Perform the system logout '//Return: True/False '//Call: security_performLogout '//Version: 1 '//Created: 08/09/2006 '//Modified:08/09/2006 Session("security_iUserID") = "" Session("security_sDisplayName") = "" Session("security_sUsername") = "" Session("security_sEmail") = "" Session("security_iParentID") = "" Call security_onLogout() End Function %> <% '************************************************** '//Script: Date and Time Functions '//Copyright: 2004-2006 Froya Limited. All rights reserved. ' No part of this code maybe used or altered without prior permission of the owner '//Created: 25/07/2006 RJ '//Modified: 24/08/2006 CC 'date switch function '************************************************** '################################################## Function dateTimeConvert (sDate, sFormat) '//Process: Convert date formats '//Param: sDate: YYYY/MM/DD ' YY/MM/DD ' YYYY-MM-DD ' YY-MM-DD ' YYYYMMDD ' YYMMDD ' DDMMYY ' YYYYMMDDTHHMMSSZ ' sFormat: UK = Standard UK format DD/MM/YY HH:MM:SS ' US = Standard US format MM/DD/YY HH:MM:SS ' ISO = International standard format YYYY/MM/DD HH:MM:SS ' UCT = Universal Time format YYYYMMDDTHHMMSSZ ' Excel = Format that Microsoft Excel uses YYYY-MM-DD THH:MM:SSZ ' Short = Shorthand format DDMMYY ' Default = Standard UK format DD/MM/YY HH:MM:SS '//Return: Date converted to format specified (sFormat) '//Call: sVar = formatDateConvert("12/13/2006", "UK") '//Version: 1 '//Created: 25/07/2006 'key ' yyyy = 2006 ' mm = 12 ' dd = 30 ' hh = 23 ' nn = 59 ' ss = 59 ' T = Time ' Z = GMT (zero time) '-VARS Dim sReturn, sYear, sMonth, sDay, sHour, sMinute, sSecond '-PROCESS On Error Resume Next 'check for time only If ((Len(sDate) = 8) And (InStr(sDate, ":"))) Then 'time only sReturn = sDate Else 'full date 'check if is short If (Len(sDate) = 6) Then 'is short date so split out date parts and recompile as uk format sDate = Mid(sDate,1,2) & "/" & Mid(sDate,3,2) & "/" & Mid(sDate,5,2) & " 00:00:00" End if 'check if is utc If ((Len(sDate) = 16) And (InStr(sDate, "T") > 0) And (InStr(sDate, "Z") > 0)) Then 'is utc date so split out date parts and recompile as uk format sDate = Mid(sDate,7,2) & "/" & Mid(sDate,5,2) & "/" & Mid(sDate,1,4) & " " & Mid(sDate,10,2) & ":" & Mid(sDate,12,2) & ":" & Mid(sDate,14,2) ElseIf ((Len(sDate) = 8) And (InStr(sDate, "/") = 0)) Then 'is utc date without time so split out date parts and recompile as uk format sDate = Mid(sDate,7,2) & "/" & Mid(sDate,5,2) & "/" & Mid(sDate,1,4) & " 00:00:00" ElseIf (Len(sDate) = 8) And (CInt(Mid(sDate,1,2)) > 31) Then 'is utc date with short year before 2000 and without time so split out date parts and recompile as uk format sDate = Mid(sDate,7,2) & "/" & Mid(sDate,4,2) & "/19" & Mid(sDate,1,2) & " 00:00:00" End if 'check if date is valid If (IsDate(sDate)) Then 'date is okay, split out date parts sYear = Year(sDate) sMonth = Month(sDate) sDay = Day(sDate) sHour = Hour(sDate) sMinute = Minute(sDate) sSecond = Second(sDate) 'now add preceding 0(zero) if required If (Len(sMonth) = 1) Then sMonth = "0" & sMonth End if If (Len(sDay) = 1) Then sDay = "0" & sDay End if If (Len(sHour) = 1) Then sHour = "0" & sHour End if If (Len(sMinute) = 1) Then sMinute = "0" & sMinute End if If (Len(sSecond) = 1) Then sSecond = "0" & sSecond End if 'select format to convert to Select Case sFormat Case "IS", "is" 'international, yyyy/mm/dd hh:nn:ss sReturn = sYear & "/" & sMonth & "/" & sDay & " " & sHour & ":" & sMinute & ":" & sSecond Case "UTC", "utc" 'Universal Time, yyyymmddThhnnssZ sReturn = sYear & sMonth & sDay & "T" & sHour & sMinute & sSecond & "Z" Case "excel" 'excel, yyyy-mm-ddThh:nn:ssZ (Universal Time variant) sReturn = sYear & "-" & sMonth & "-" & sDay & "T" & sHour & ":" & sMinute & ":" & sSecond & "Z" Case "UK", "uk" 'UK, dd/mm/yyyy hh:nn:ss sReturn = sDay & "/" & sMonth & "/" & sYear & " " & sHour & ":" & sMinute & ":" & sSecond Case "US", "us" 'US, mm/dd/yyyy hh:nn:ss sReturn = sMonth & "/" & sDay & "/" & sYear & " " & sHour & ":" & sMinute & ":" & sSecond Case "short" 'short, ddmmyy sReturn = sDay & sMonth & Mid(sYear,3,2) Case Else 'UK, dd/mm/yyyy hh:nn:ss sReturn = sDay & "/" & sMonth & "/" & sYear & " " & sHour & ":" & sMinute & ":" & sSecond End Select Else 'not a date so return false sReturn = "" End If 'IsDate check End If 'Time check '-RETURN dateTimeConvert = sReturn End Function %> <% '************************************************** '//Script: inc_stringManip.asp '//Copyright: 2004-2006 Froya Limited. All rights reserved. ' No part of this code maybe used or altered without prior permission of the owner '//Created: 04/10/2006 '//Modified: 04/10/2006 '************************************************** 'Requires ' 'Function List ' stringManip_HTMLStrip(sHTML) ' stringManip_HTMLSafe(sHTML) ' stringManip_createLabel(sString) ' stringManip_profanityRemove(iType) '################################################## Function stringManip_HTMLStrip(sHTML) '//Process: Make a string containing HTML safe to output (stripping HTML tags) '//Param: sHTML : HTML to make safe '//Return: safe HTML '//Call: Response.Write stringManip_HTMLStrip("test") '//Version: 1 '//Created: 04/10/2006 '//Modified:05/10/2006 '-VARS Dim sReturn : sReturn = "" Dim iPosition : iPosition = 1 'strat position Dim iStart 'start of the string to extrapolate '-PROCESS 'repplace
sHTML = Replace(sHTML, "
", Chr(10)) iPosition = 1 'default the position to the start of the XML document iStart = InStr(iPosition, sHTML, "<") 'while we're still finding variables, loop and identify them Do While Not iStart = 0 '0 denotes the end of the search (no more found) sReturn = sReturn & Mid(sHTML, iPosition, (iStart-iPosition)) iPosition = InStr(iStart, sHTML, ">") + 1 iStart = InStr(iPosition, sHTML, "<") Loop sReturn = sReturn & Mid(sHTML, iPosition) '-RETURN stringManip_HTMLStrip = sReturn End Function '################################################## Function stringManip_HTMLSafe(sHTML) '//Process: Make a string containing HTML safe to output '//Param: sHTML : HTML to make safe '//Return: safe HTML '//Call: Response.Write stringManip_HTMLSafe("test") '//Version: 1 '//Created: 04/10/2006 '//Modified:05/10/2006 '-VARS Dim sReturn : sReturn = sHTML '-PROCESS sReturn = Replace(sReturn, ">", ">") sReturn = Replace(sReturn, "<", "<") '-RETURN stringManip_HTMLSafe = sReturn End Function '################################################## Function stringManip_createLabel(sString) '//Process: Create a label from a mixed string (camelCase, caps, spaces) '//Param: sString : string to make a label for '//Return: finished title '//Call: Response.Write stringManip_createLabel("myNewTitle") '//Version: 1 '//Created: 04/10/2006 '//Modified:05/10/2006 '-VARS Dim sLabel : sLabel = sString 'holds the finished title string Dim iPosition : iPosition = 1 'set initial position for string searches Dim iStart 'position to start space searches Dim bCheck : bCheck = false 'check for an all uppercase string '-lowercase '_' titles 'if the string contacins '_' then start by making it all lower case to help capitalise the first letter 'this is safe now as we know it's not an 'un-spaced' string as it's using '_'s If (InStr(1, sLabel, "_") <> 0) Then sLabel = LCase(sLabel) 'convert to lower case End If 'ALL UPPER CASE to lowercase iStart = 1 Do While iStart <= Len(sLabel) 'check if uppercase/other than If Not (Asc(Mid(sLabel, iStart, 1)) > 64 And Asc(Mid(sLabel, iStart, 1)) < 91) Then bCheck = true End If iStart = iStart + 1 Loop 'check for all upper If (bCheck = false) Then sLabel = LCase(sLabel) 'convert to lower case End If '-UNDERSCORE sLabel = Replace(sLabel, "_", " ") 'capitalise first letter sLabel = Replace(sLabel, Mid(sLabel, 1, 1), UCase(Mid(sLabel, 1, 1)), 1, 1) 'set up the starting position for first space iStart = InStr(iPosition, sLabel, " ") 'loop through all spaces, chcking for capital letters and converting them (Eg spaces_and_underscores) Do While Not iStart = 0 sLabel = Mid(sLabel, 1, iStart-1) & Replace(sLabel, Mid(sLabel, iStart+1, 1), UCase(Mid(sLabel, iStart+1, 1)), iStart, 1) iPosition = iStart + 1 iStart = InStr(iPosition, sLabel, " ") Loop '-CAMMEL CASE 'check for a string with capitals and no spaces, creating the spaces if needed (Eg LettersAndSpaces) iStart = 1 Do While iStart <= Len(sLabel) 'check if uppercase If (Asc(Mid(sLabel, iStart, 1)) > 64 And Asc(Mid(sLabel, iStart, 1)) < 91) Then 'uppercase letter, check if there is a letter before and if it's not a space or ID or ADS If (iStart > 1) Then If (Mid(sLabel, iStart-1, 1) <> " ") Then 'add the space before the capital letter sLabel = Mid(sLabel, 1, iStart-1) & " " & Mid(sLabel, iStart, Len(sLabel)) End if End If End If iStart = iStart + 1 Loop '-FIX ID If (sString = "ID") Then 'correct capitalised ID field sLabel = "ID" End If sLabel = Replace(sLabel,"I D","ID") 'RETURN stringManip_createLabel = sLabel 'return completed title End Function '################################################## Function stringManip_profanityRemove(sString, iType) '//Process: remove certain words and profanities '//Param: sString : string to strip profanities from ' iType : 0=null profanities / 1=**** them '//Return: string with no profanity '//Call: Response.Write stringManip_profanityRemove(sString, 1) '//Version: 1 '//Created: 10/10/2006 '//Modified:10/10/2006 '-VARS Dim sReturn : sReturn = sString Dim sProfanities : sProfanities = "fucking,fuck,shit,bastard,bastaurd,pussy,cock,bitch,twat,wanker,cunt,fisting,stab,clit,tits,prostitute,prossy,prostetute,pedofile,pedophile,masterbate,wank,xxx" '-PROCESS aProfanities = Split(sProfanities, ",") For i = 0 to UBound(aProfanities) 'the UBound function returns 3 If (iType = 1) Then sReplace = Mid(aProfanities(i),1,1) For i2 = 1 To Len(aProfanities(i))-2 sReplace = sReplace & "*" Next sReplace = sReplace & Mid(aProfanities(i),Len(aProfanities(i)),1) sReturn = Replace(sReturn,aProfanities(i),sReplace) Else sReturn = Replace(sReturn,aProfanities(i),"") End If Next '-RETURN stringManip_profanityRemove = sReturn End Function %> <% '************************************************** '//Script: Simple Form Generator '//Copyright: 2004-2006 Froya Limited. All rights reserved. ' No part of this code maybe used or altered without prior permission of the owner '//Created: 09/10/2006 CC '//Modified: 09/10/2006 CC '************************************************** 'Requires ' inc_dbAccess.asp ' inc_fx.asp ' inc_sda.asp 'Function List ' simpleForm_createInput(sTable) '################################################## Function simpleForm_createInput(oConn, sTable, sFields) '//Process: Create an input form from a database table '//Param: oConn: database connection ' sTable: table to create the form for ' sFields: field order and divides (name,address,postcode|email,telephone,fax) '//Return: Simple datatable form for public input '//Call: sReturn = simpleForm_createInput(oConn, "product", "name, quantity, price"") '//Version: 1 '//Created: 10/10/2006 '//Modified:10/10/2006 '-VARS Dim oRS Dim sReturn : sReturn = "" 'return variable Dim sSql : sSql = "" 'holds SQL strings Dim iFieldCount : iFieldCount = 0 'the number of fields in the table sFields = Trim(Replace(sFields," ","")) 'remove whitespace '-PROCESS ' On Error Resume Next 'check if table exists If (dbTableExists(sTable, oConn)) Then 'table exists 'open recordset, check for specified fields If (sFields <> "") Then sSql = "SELECT TOP 1 " & Trim(Replace(sFields, "|", ",")) & " FROM [" & sTable & "];" Else sSql = "SELECT TOP 1 * FROM [" & sTable & "];" End If Set oRS = dbOpenRS(oConn, sSql) 'get number of fields returned iFieldCount = oRS.Fields.Count 'SETUP RECORD FORM sReturn = sReturn & "
" & VbCrLF sReturn = sReturn & " " & VbCrLF sReturn = sReturn & " " 'DISPLAY RECORD TABLE sReturn = sReturn & "" & VbCrLF sReturn = sReturn & "" & VbCrLF sReturn = sReturn & "" & VbCrLF sReturn = sReturn & "" & VbCrLF sReturn = sReturn & "" & VbCrLF sReturn = sReturn & "" & VbCrLF sReturn = sReturn & "" & VbCrLF '-Check for custom field order If (sFields <> "*" And sFields <> "") Then 'custom field list execution ' oRS.MoveFirst ' Do While Not (oRS.EOF) ' If (Not oRS.EOF) Then 'get end position iEndA = InStr(1,sFields,",") iEndB = InStr(1,sFields,"|") If (iEndA <> 0 And iEndB <> 0) Then If (iEndB > iEndA) Then iEnd = iEndA Else iEnd = iEndB End If 'iEnd ElseIf (iEndA = 0) Then iEnd = iEndB Else iEnd = iEndA End If iStart = 1 Do While iEnd <> 0 'display field sField = Replace(Replace(Mid(sFields, iStart, iEnd-iStart),"[",""),"]","") If (fx_getExtensionValue(sTable, oRS(sField).Name, 2) = "Hidden") Then 'check if hidden 'do not display ElseIf (fx_getExtensionValue(sTable, oRS(sField).Name, 2) = "IDLog") Then 'ID ' ignore ID ' sReturn = sReturn & fx_getFormField(oConn, sTable, oRS(sField).Name, fx_getExtensionValue(sTable, oRS(sField).Name, 8), oRS(sField).Type, 1) Else If (errorShowObject(oRS(sField).Name)) Then sReturn = sReturn & "" bError = True Else sReturn = sReturn & "" bError = False End If sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" & VbCrLF 'check for password (confirm) If (LCase(fx_formatExtFieldAttr(sTable, sField, iType, 2)) = "password") Then If (bError) Then sReturn = sReturn & "" Else sReturn = sReturn & "" End If sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" & VbCrLF End If End If 'check for break If (Mid(sFields, iEnd, 1) = "|") Then sReturn = sReturn & "" End If 'get end position iStart = iEnd+1 iEndA = InStr(iEnd+1,sFields,",") iEndB = InStr(iEnd+1,sFields,"|") If (iEndA <> 0 And iEndB <> 0) Then If (iEndB > iEndA) Then iEnd = iEndA Else iEnd = iEndB End If 'iEnd ElseIf (iEndA = 0) Then iEnd = iEndB Else iEnd = iEndA End If bRan = True 'Set that it's ran once, so we can show the last field Loop 'iEnd <> 0 '-display last field if ran If (bRan) Then 'display last field sField = Replace(Replace(Mid(sFields, iStart),"[",""),"]","") If (fx_getExtensionValue(sTable, oRS(sField).Name, 2) = "Hidden") Then 'check if hidden 'do not display ElseIf (fx_getExtensionValue(sTable, oRS(sField).Name, 2) = "IDLog") Then 'ID ' sReturn = sReturn & fx_getFormField(oConn, sTable, oRS(sField).Name, fx_getExtensionValue(sTable, oRS(sField).Name, 8), oRS(sField).Type, 1) Else If (errorShowObject(oRS(sField).Name)) Then sReturn = sReturn & "" Else sReturn = sReturn & "" End If sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" & VbCrLF 'check for password (confirm) If (LCase(fx_formatExtFieldAttr(sTable, sField, iType, 2)) = "password") Then If (bError) Then sReturn = sReturn & "" Else sReturn = sReturn & "" End If sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" & VbCrLF End If End If End If ' oRS.MoveNext ' Loop 'oRS ' End If Else '-normal field execution For i=0 To iFieldCount-1 If (fx_getExtensionValue(sTable, oRS(sField).Name, 2) = "Hidden") Then 'check if hidden 'do not display ElseIf (fx_getExtensionValue(sTable, oRS(sField).Name, 2) = "IDLog") Then 'ID ' sReturn = sReturn & fx_getFormField(oConn, sTable, oRS(sField).Name, fx_getExtensionValue(sTable, oRS(sField).Name, 8), oRS(sField).Type, 1) Else If (errorShowObject(oRS(sField).Name)) Then sReturn = sReturn & "" Else sReturn = sReturn & "" End If sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" & VbCrLF 'check for password (confirm) If (LCase(fx_formatExtFieldAttr(sTable, sField, iType, 2)) = "password") Then If (bError) Then sReturn = sReturn & "" Else sReturn = sReturn & "" End If sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" & VbCrLF End If End If Next End If 'field list check sReturn = sReturn & VbTab & VbTab & "" & VbCrLF sReturn = sReturn & "
" & stringManip_createLabel(fx_getExtensionValue(sTable, oRS(sField).Name, 7)) & "" & fx_getFormField(oConn, sTable, oRS(sField).Name, fx_getExtensionValue(sTable, oRS(sField).Name, 8), oRS(sField).Type, 1) & "
Password Confirm *
" & stringManip_createLabel(fx_getExtensionValue(sTable, oRS(sField).Name, 7)) & "" & fx_getFormField(oConn, sTable, oRS(sField).Name, fx_getExtensionValue(sTable, oRS(sField).Name, 8), oRS(sField).Type, 1) & "
Password Confirm *
" & stringManip_createLabel(fx_getExtensionValue(sTable, oRS(sField).Name, 7)) & "" & fx_getFormField(oConn, sTable, oRS(sField).Name, fx_getExtensionValue(sTable, oRS(sField).Name, 8), oRS(sField).Type, 1) & "
Password Confirm *
" & VbCrLF sReturn = sReturn & "
" & VbCrLF 'FORM FORM CLOSE sReturn = sReturn & "
" & VbCrLF Else 'invalid table Call errorTrap("The selected table could not be accessed at this time") End If 'check if table exists '-TIDY ' oRS.Close() Set oRS = Nothing '-RETURN simpleForm_createInput = sReturn End Function '################################################# Function simpleForm_createUpdate(oConn, sTable, sFields, sFilter) '//Process: Edit/Modify Record in a view or table/view '//Param: oConn : Database Connection ' sTable : Table to load record from ' sFields : Field to match ID to ' sFilter : Filter to get back the record to edit '//Return: Table of values ready to edit '//Call: Response.Write simpleForm_createUpdate(oConn, sTable, sField, iRecord) '//Version: 1 '//Created: 11/11/2006 '//Modified:11/10/2006 '-VARS Dim oRS Dim sReturn : sReturn = "" 'return variable Dim sSql : sSql = "" 'holds SQL strings Dim iFieldCount : iFieldCount = 0 'the number of fields in the table sFields = Trim(Replace(sFields," ","")) 'remove whitespace '-PROCESS ' On Error Resume Next 'check if table exists If (dbTableExists(sTable, oConn)) Then 'table exists 'open recordset, check for specified fields If (sFields <> "") Then sSql = "SELECT TOP 1 " & Trim(Replace(sFields, "|", ",")) & " FROM [" & sTable & "] WHERE (" & sFilter & ");" Else sSql = "SELECT TOP 1 * FROM [" & sTable & "] WHERE (" & sFilter & ");" End If Set oRS = dbOpenRS(oConn, sSql) 'get number of fields returned iFieldCount = oRS.Fields.Count 'Check for returned data If (oRS.RecordCount <> 0) Then 'SETUP RECORD FORM sReturn = sReturn & "
" & VbCrLF sReturn = sReturn & " " & VbCrLF sReturn = sReturn & " " 'DISPLAY RECORD TABLE sReturn = sReturn & "" & VbCrLF sReturn = sReturn & "" & VbCrLF sReturn = sReturn & "" & VbCrLF sReturn = sReturn & "" & VbCrLF sReturn = sReturn & "" & VbCrLF sReturn = sReturn & "" & VbCrLF sReturn = sReturn & "" & VbCrLF '-Check for custom field order If (sFields <> "*" And sFields <> "") Then 'custom field list execution 'get end position iEndA = InStr(1,sFields,",") iEndB = InStr(1,sFields,"|") If (iEndA <> 0 And iEndB <> 0) Then If (iEndB > iEndA) Then iEnd = iEndA Else iEnd = iEndB End If 'iEnd ElseIf (iEndA = 0) Then iEnd = iEndB Else iEnd = iEndA End If iStart = 1 Do While iEnd <> 0 'display field sField = Replace(Replace(Mid(sFields, iStart, iEnd-iStart),"[",""),"]","") If (fx_getExtensionValue(sTable, oRS(sField).Name, 2) = "Hidden") Then 'check if hidden 'do not display ElseIf (fx_getExtensionValue(sTable, oRS(sField).Name, 2) = "IDLog") Then 'ID 'do not display Else 'display If (errorShowObject(oRS(sField).Name)) Then sReturn = sReturn & "" Else sReturn = sReturn & "" End If 'display the form item sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" & VbCrLF 'check for password (confirm) If (LCase(fx_formatExtFieldAttr(sTable, sField, iType, 2)) = "password") Then If (bError) Then sReturn = sReturn & "" Else sReturn = sReturn & "" End If sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" & VbCrLF End If End If 'check for break If (Mid(sFields, iEnd, 1) = "|") Then sReturn = sReturn & "" End If 'get end position iStart = iEnd+1 iEndA = InStr(iEnd+1,sFields,",") iEndB = InStr(iEnd+1,sFields,"|") If (iEndA <> 0 And iEndB <> 0) Then If (iEndB > iEndA) Then iEnd = iEndA Else iEnd = iEndB End If 'iEnd ElseIf (iEndA = 0) Then iEnd = iEndB Else iEnd = iEndA End If bRan = True 'Set that it's ran once, so we can show the last field Loop 'iEnd <> 0 '-display last field if ran If (bRan) Then 'display last field sField = Replace(Replace(Mid(sFields, iStart),"[",""),"]","") If (fx_getExtensionValue(sTable, oRS(sField).Name, 2) = "Hidden") Then 'check if hidden 'do not display ElseIf (fx_getExtensionValue(sTable, oRS(sField).Name, 2) = "IDLog") Then 'ID 'do not display Else 'display If (errorShowObject(oRS(sField).Name)) Then sReturn = sReturn & "" Else sReturn = sReturn & "" End If 'display the form item sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" & VbCrLF 'check for password (confirm) If (LCase(fx_formatExtFieldAttr(sTable, sField, iType, 2)) = "password") Then If (bError) Then sReturn = sReturn & "" Else sReturn = sReturn & "" End If sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" & VbCrLF End If End If End If Else '-normal field execution For i=0 To iFieldCount-1 If (fx_getExtensionValue(sTable, oRS(sField).Name, 2) = "Hidden") Then 'check if hidden 'do not display ElseIf (fx_getExtensionValue(sTable, oRS(sField).Name, 2) = "IDLog") Then 'ID 'do not display Else 'display If (errorShowObject(oRS(sField).Name)) Then sReturn = sReturn & "" Else sReturn = sReturn & "" End If 'display the form item sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" & VbCrLF 'check for password (confirm) If (LCase(fx_formatExtFieldAttr(sTable, sField, iType, 2)) = "password") Then If (bError) Then sReturn = sReturn & "" Else sReturn = sReturn & "" End If sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" & VbCrLF End If End If Next End If 'field list check sReturn = sReturn & VbTab & VbTab & "" & VbCrLF sReturn = sReturn & "
" & stringManip_createLabel(fx_getExtensionValue(sTable, oRS(sField).Name, 7)) & "" & fx_getFormField(oConn, sTable, oRS(sField).Name, oRS(sField).Value, oRS(sField).Type, 1) & "
Password Confirm *
" & stringManip_createLabel(fx_getExtensionValue(sTable, oRS(sField).Name, 7)) & "" & fx_getFormField(oConn, sTable, oRS(sField).Name, oRS(sField).Value, oRS(sField).Type, 1) & "
Password Confirm *
" & stringManip_createLabel(fx_getExtensionValue(sTable, oRS(sField).Name, 7)) & "" & fx_getFormField(oConn, sTable, oRS(sField).Name, oRS(sField).Value, oRS(sField).Type, 1) & "
Password Confirm *
" & VbCrLF sReturn = sReturn & "
" & VbCrLF sReturn = sReturn & "
" & VbCrLF Else 'no fields Call errorTrap("No record found") End If 'no records Else 'invalid table Call errorTrap("The selected table could not be accessed at this time") End If 'check if table exists '-TIDY oRS.Close() Set oRS = Nothing '-RETURN simpleForm_createUpdate = sReturn End Function '################################################# Function simpleForm_insertRecord(oConn, sTable, sFields, sIDField) '//Process: INSERT a record in the table according to submitted form '//Param: oConn = database connection ' sTable = table name ' sFields: field order and divides (name,address,postcode|email,telephone,fax) ' sIDField : field to get a new ID for '//Return: true/false (errors) '//Call: Call dbExecute(simpleForm_insertRecord, "product") '//Version: 1 '//Created: 28/09/06 CC '//Modified:28/09/06 CC '-VARS Dim oRSTemp 'temp recordset Dim sSql 'sql to execute/build Dim iFieldCount : iFieldCount = 0 'cound fields in table Dim bErrorGlobal : bErrorGlobal = False 'hold database validation errors Dim bError : bError = False 'hold field loop error Dim iType 'hold field type Dim sField 'hold field name Dim sValue 'hold field value Dim sSqlFields : sSqlFields = "" 'hold fields to insert Dim sSqlValues : sSqlValues = "" 'hold values to insert sFields = Trim(Replace(sFields," ","")) 'remove whitespace '-PROCESS 'get datatypes If (sFields <> "") Then sSql = "SELECT TOP 1 " & Trim(Replace(sFields, "|", ",")) & " FROM [" & sTable & "];" Else sSql = "SELECT TOP 1 * FROM [" & sTable & "];" End If Set oRSTemp = dbOpenRS(oConn, sSql) iFieldCount = oRSTemp.fields.count -1 'loop through fields, validating data For i=0 to iFieldCount bError = False bNullValue = False iType = oRSTemp(i).Type sField = oRSTemp(i).Name sValue = Request.Form(sField) 'check ID field If (sField = sIDField) Then sValue = dbNewID(oConn, sField) End If ' If (sField <> "ID") Then 'ID field cannot be unpdated 'analyse datatype Select Case iType 'NUMBER - LONG INT Case 3: sValue = Replace(sValue , "£", "") 'strip pound sign If (sValue <> "") Then sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "" & sValue & "," ElseIf (VarType(sValue) = 0) Then 'do nothing bNullValue = True ElseIf (sValue = "") Then sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "NULL," Else errorTrapObject(sField) 'trap field associated with the error Call errorTrap("You did not enter a numeric value for the field " & fx_getExtensionValue(sTable, sField, 7)) bError = True End If 'NUMBER - BYTE Case 17: sValue = Replace(sValue , "£", "") 'strip pound sign 'this datatype also carries the logical ext field If (fx_getExtensionData(sTable, sField, 2) = "Logical") Then If (sValue <> "") Then sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "1," Else sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "0," End If ElseIf (VarType(sValue) = 0) then sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "NULL," ElseIf (sValue <> "") Then sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "" & sValue & "," Else errorTrapObject(sField) 'trap field associated with the error Call errorTrap("You did not enter a numeric value for the field " & fx_getExtensionValue(sTable, sField, 7)) bError = True End If 'NUMBER - DOUBLE Case 5: sValue = Replace(sValue , "£", "") 'strip pound sign If (IsNumeric(sValue)) Then sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "" & sValue & "," ElseIf (sValue = "") then sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "NULL," Else errorTrapObject(sField) 'trap field associated with the error Call errorTrap("You did not enter a numeric value for the field " & fx_getExtensionValue(sTable, sField, 7)) bError = True End If 'TEXT Case 202: If (InStr(Request.Form, sField & "=") = 0) Then 'check for null value except for logical fields bNullValue = True Else sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "'" & dbFix(sValue) & "'," End If 'MEMO Case 203: If (InStr(Request.Form, sField & "=") = 0) Then 'check for null value except for logical fields bNullValue = True Else sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "'" & dbFix(sValue) & "'," End If 'DATE / TIME Case 7: If (IsDate(sValue)) Then sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "#" & dateTimeConvert(sValue, "IS") & "#," 'dd/mm/yyyy -> yyyy/mm/dd ElseIf (sValue = "") Then sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "NULL," Else errorTrapObject(sField) 'trap field associated with the error Call errorTrap("You did not enter a proper date for the field " & fxFormatExtFieldName(sTable, sField, False)) bError = True End If 'CURRENCY Case 6: sValue = Replace(sValue , "£", "") 'strip pound sign If (IsNumeric(sValue)) Then sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "" & sValue & "," ElseIf (sValue = "") then sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "NULL," Else errorTrapObject(sField) 'trap field associated with the error Call errorTrap("You did not enter a numeric value for the field " & fx_getExtensionValue(sTable, sField, 7)) bError = True End If Case Else: 'NOTHING End Select 'iType 'if null or an error, remove from the query If (bError) then bErrorGlobal = True 'generate error End If bError = False 'reset error catch ' End If 'if not ID Next 'Field 'build sql sSql = "INSERT INTO [" & sTable & "] (" & Left(sSqlFields, Len(sSqlFields)-1) & ") VALUES (" & Left(sSqlValues, Len(sSqlValues)-1) & ");" ' d sSql,1 'execure if not an error If (not bErrorGlobal) Then On Error Resume Next Call dbExecute(oConn, sSql) 'set last table and ID for later use sSql = "SELECT TOP 1 * FROM " & sTable & ";" Set oRSTemp = dbOpenRS(oConn, sSql) sSql = "SELECT Max(" & oRSTemp(0).Name & ") As lastID FROM " & sTable & ";" Set oRSTemp = dbOpenRS(oConn, sSql) Session("dbLastTable") = sTable Session("dbLastID") = oRSTemp("lastID") Set oRSTemp = Nothing End If '-RETURN If (oConn.Errors.Count = 0) And (bErrorGlobal = False) Then 'success Call messageTrap("Record Added Successfully") 'catch message simpleForm_insertRecord = True Else 'errors simpleForm_insertRecord = False End if End Function '################################################# Function simpleForm_updateRecord(oConn, sTable, sFields, sFilter) '//Process: Update a record in the table according to submitted form '//Param: oConn = database connection ' sTable = table name ' sFields = field order and divides (name,address,postcode|email,telephone,fax) ' sFilter = filter of record to update '//Return: true/false (errors) '//Call: Call dbExecute(simpleForm_updateRecord, "product") '//Version: 1 '//Created: 11/10/06 CC '//Modified:11/10/06 CC '-VARS Dim oRSTemp 'temp recordset Dim sSql 'sql to execute/build Dim iFieldCount : iFieldCount = 0 'cound fields in table Dim bErrorGlobal : bErrorGlobal = False 'hold database validation errors Dim bError : bError = False 'hold field loop error Dim iType 'hold field type Dim sField 'hold field name Dim sValue 'hold field value Dim sSqlFields : sSqlFields = "" 'hold fields and values to update sFields = Trim(Replace(sFields," ","")) 'remove whitespace '-PROCESS 'get datatypes If (sFields <> "") Then sSql = "SELECT TOP 1 " & Trim(Replace(sFields, "|", ",")) & " FROM [" & sTable & "] WHERE (" & sFilter & ");" Else sSql = "SELECT TOP 1 * FROM [" & sTable & "] WHERE (" & sFilter & ");" End If Set oRSTemp = dbOpenRS(oConn, sSql) iFieldCount = oRSTemp.fields.count -1 'loop through fields, validating data For i=0 to iFieldCount bError = False bNullValue = False iType = oRSTemp(i).Type sField = oRSTemp(i).Name sValue = Request.Form(sField) If (sField <> "ID") Then 'ID field cannot be unpdated 'analyse datatype Select Case iType 'NUMBER - LONG INT Case 3: sValue = Replace(sValue , "£", "") 'strip pound sign If (sValue <> "") Then sSqlFields = sSqlFields & "[" & sField & "]=" & sValue & "," ElseIf (VarType(sValue) = 0) Then 'do nothing bNullValue = True ElseIf (sValue = "") then sSqlFields = sSqlFields & "[" & sField & "]=NULL," Else errorTrapObject(sField) 'trap field associated with the error Call errorTrap("You did not enter a numeric value for the field " & fx_getExtensionValue(sTable, sField, 7)) bError = True End If 'NUMBER - BYTE Case 17: sValue = Replace(sValue , "£", "") 'strip pound sign 'this datatype also carries the logical ext field If (fx_getExtensionData(sTable, sField, 2) = "Logical") Then If (sValue <> "") Then sSqlFields = sSqlFields & "[" & sField & "]=1," Else sSqlFields = sSqlFields & "[" & sField & "]=0," End If ElseIf (VarType(sValue) = 0) then sSqlFields = sSqlFields & "[" & sField & "]=NULL," ElseIf (sValue <> "") Then sSqlFields = sSqlFields & "[" & sField & "]=" & sValue & "," Else errorTrapObject(sField) 'trap field associated with the error Call errorTrap("You did not enter a numeric value for the field " & fx_getExtensionValue(sTable, sField, 7)) bError = True End If 'NUMBER - DOUBLE Case 5: sValue = Replace(sValue , "£", "") 'strip pound sign If (IsNumeric(sValue)) Then sSqlFields = sSqlFields & "[" & sField & "]=" & sValue & "," ElseIf (sValue = "") then sSqlFields = sSqlFields & "[" & sField & "]=NULL," Else errorTrapObject(sField) 'trap field associated with the error Call errorTrap("You did not enter a numeric value for the field " & fx_getExtensionValue(sTable, sField, 7)) bError = True End If 'TEXT Case 202: If (InStr(Request.Form, sField & "=") = 0) Then 'check for null value except for logical fields bNullValue = True Else sSqlFields = sSqlFields & "[" & sField & "]='" & dbFix(sValue) & "'," End If 'MEMO Case 203: If (InStr(Request.Form, sField & "=") = 0) Then 'check for null value except for logical fields bNullValue = True Else sSqlFields = sSqlFields & "[" & sField & "]='" & dbFix(sValue) & "'," End If 'DATE / TIME Case 7: If (IsDate(sValue)) Then sSqlFields = sSqlFields & "[" & sField & "]=#" & dateTimeConvert(sValue, "IS") & "#," 'dd/mm/yyyy -> yyyy/mm/dd ElseIf (sValue = "") Then sSqlFields = sSqlFields & "[" & sField & "]=NULL," Else errorTrapObject(sField) 'trap field associated with the error Call errorTrap("You did not enter a proper date for the field " & fxFormatExtFieldName(sTable, sField, False)) bError = True End If 'CURRENCY Case 6: sValue = Replace(sValue , "£", "") 'strip pound sign If (IsNumeric(sValue)) Then sSqlFields = sSqlFields & "[" & sField & "]=" & sValue & "," ElseIf (sValue = "") then sSqlFields = sSqlFields & "[" & sField & "]=NULL," Else errorTrapObject(sField) 'trap field associated with the error Call errorTrap("You did not enter a numeric value for the field " & fx_getExtensionValue(sTable, sField, 7)) bError = True End If Case Else: 'NOTHING End Select 'iType 'if null or an error, remove from the query If (bError) then bErrorGlobal = True 'generate error End If bError = False 'reset error catch End If 'if not ID Next 'Field 'build sql sSql = "UPDATE [" & sTable & "] SET " & Left(sSqlFields, Len(sSqlFields)-1) & " WHERE " & sFilter & ";" ' d sSql,1 'execure if not an error If (not bErrorGlobal) Then On Error Resume Next Call dbExecute(oConn, sSql) Set oRSTemp = Nothing End If '-RETURN If (oConn.Errors.Count = 0) And (bErrorGlobal = False) Then 'success simpleForm_updateRecord = True Else 'errors simpleForm_updateRecord = False End if End Function '################################################# Function simpleForm_loadPublicPermissions() '//Process: Load permissions into memory for quick access, for public pages '//Return Session = oSystemPermission[userID][objType][objRef][Permission] '//Call: Call simpleForm_loadPublicPermissions() '//Version: 1 '//Created: 10/10/2006 '//Modified:10/10/2006 '-VARS Dim oRSPermissions 'database connection '-PROCESS ' On Error Resume Next 'We'll catch errors 'Build sql and save each permission sSql = "SELECT DISTINCT * FROM [systemPermission] WHERE (userID=(SELECT ID FROM [systemUser] WHERE username='anon'));" Set oRSPermissions = DBOpenRS(oConn, sSql) If (oRSPermissions.RecordCount <> 0) Then '-Loop through any permissions Do While Not oRSPermissions.EOF '-check each permission type and save to session Session("fx_systemPermission[" & oRSPermissions("objectType") & "][" & oRSPermissions("objectRef") & "][RC]") = oRSPermissions("RC") Session("fx_systemPermission[" & oRSPermissions("objectType") & "][" & oRSPermissions("objectRef") & "][WC]") = oRSPermissions("WC") Session("fx_systemPermission[" & oRSPermissions("objectType") & "][" & oRSPermissions("objectRef") & "][DC]") = oRSPermissions("DC") Session("fx_systemPermission[" & oRSPermissions("objectType") & "][" & oRSPermissions("objectRef") & "][RO]") = oRSPermissions("RO") Session("fx_systemPermission[" & oRSPermissions("objectType") & "][" & oRSPermissions("objectRef") & "][WO]") = oRSPermissions("WO") Session("fx_systemPermission[" & oRSPermissions("objectType") & "][" & oRSPermissions("objectRef") & "][DO]") = oRSPermissions("DO") ' Session("fx_systemPermission[" & oRSPermissions("objectType") & "][" & oRSPermissions("objectRef") & "][VS]") = oRSPermissions("VS") oRSPermissions.MoveNext Loop End If '-CLOSE Set oRSPermissions = Nothing End Function %> <% '************************************************* '//Description: file functions '//Copyright: Copyright©2005 Froya Ltd. '//Created: 27/10/05 BK '//Modified '************************************************* '################################################# Function fileLoad(sFilePath) '//Process: load file and return contents Dim sReturn '-process Set oFS = Server.CreateObject("Scripting.FileSystemObject") Set oFile = oFS.GetFile(sFilePath) Set oTextStream = oFile.OpenAsTextStream(1, -2) sReturn = oTextStream.ReadAll fileLoad = sReturn Set oFS = Nothing Set oFile = Nothing Set oTextStream = Nothing End Function '################################################# Function fileSave(sFilePath, sString) '//Process: load file and return contents Dim oFS, oTextStream '-process Set oFS = CreateObject("Scripting.FileSystemObject") Set oTextStream = oFS.OpenTextFile(Server.MapPath(sFilePath), 2, true) oTextStream.Write (sString) oTextStream.Close Set oFS = Nothing Set oTextStream = Nothing End Function %> <% '************************************************* '//Description: Formatting functions for manipulating data '//Copyright: Copyright©2005 Froya Ltd. '//Created: ??/??/05 Chris Cook '//Modified 03/10/05 Chris Cook - Rewrite of functions '************************************************* '-VAR 'Dim bDAllowed : bDAllowed = True 'Enables and Disables all debug functions '################################################# Function dServer(iOption) '//Process: Go through all of the server session variables and list them sReturn = "

HTTP & Server Variables:

" sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" For Each servervariable in request.servervariables 'don't display all and raw, these illw be listed anyhow If (servervariable <> "ALL_HTTP" AND servervariable <> "ALL_RAW") Then sReturn = sReturn & "" End If Next sReturn = sReturn & "
Server VariableField Value
 
" & servervariable & "" & request.servervariables(servervariable) & "
" d sReturn, iOption End Function '################################################# Function dSessionsSpecial(sStart, iOption) '//Process: Go through all of the session vars and list them On Error Resume Next sReturn = "

Session Variables:

" sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" '---List all sessions For Each oSession In Session.Contents() If (Mid(oSession,1,Len(sStart)) = sStart) Then 'display any array data If (IsArray(Session(oSession))) Then sReturn = sReturn & "" For iCount = LBound(Session(oSession)) to UBound(Session(oSession)) sReturn = sReturn & "" Next Else sReturn = sReturn & "" End If End If Next sReturn = sReturn & "
Session VariableField Value
 
" & oSession & "ARRAY:
(" & iCount & ")     :     " & Session(oSession)(iCount) & "
" & oSession & "" & Session.Contents(oSession) & "
" d sReturn, iOption End Function '################################################# Function dSessions(iOption) '//Process: Go through all of the session vars and list them On Error Resume Next sReturn = "

Session Variables:

" sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" '---List all sessions For Each oSession In Session.Contents() 'display any array data If (IsArray(Session(oSession))) Then sReturn = sReturn & "" For iCount = LBound(Session(oSession)) to UBound(Session(oSession)) sReturn = sReturn & "" Next Else sReturn = sReturn & "" End If Next sReturn = sReturn & "
Session VariableField Value
 
" & oSession & "ARRAY:
(" & iCount & ")     :     " & Session(oSession)(iCount) & "
" & oSession & "" & Session.Contents(oSession) & "
" d sReturn, iOption End Function '################################################# Function dForm(iOption) '//Process: List all items just submitted from a form (iEnd; 1=yes, 0=no) 'loop through all items and display them sReturn = "

Form Fields:

" sReturn = sReturn & "" sReturn = sReturn & "" For Each item In request.form sReturn = sReturn & "" Next sReturn = sReturn & "
Form FieldField Value
" & item & "" & request.form(item) & " 
" d sReturn, iOption End Function '################################################# Function dRS(oRS, iOption) '//Process: List a recordset and data sReturn = "

database RecordSet:

" sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "" Do While Not (oRS.EOF) 'loop through records 'add the selection For Each field In oRS.Fields sReturn = sReturn & "" Next sReturn = sReturn & "" oRS.MoveNext 'next record Loop 'record set loop oRS sReturn = sReturn & "
Database FieldField ValueField Type
 
" & field.name & " " & field.value & " " & field.type & " 
 
" d sReturn, iOption End Function '################################################# Function dArray(aArray, iOption) '//Process: List the full field array and it's values sReturn = "

Array:

" sReturn = "" sReturn = sReturn & "" sReturn = sReturn & "" For i = 0 to uBound(aArray) sReturn = sReturn & "" If (aArray(i) <> "") Then aElement = Split(Replace(aArray(i),vbTab,""),",") If (InStr(aElement(1), "$") = 0)Then sReturn = sReturn & "" Else sReturn = sReturn & "" End If End If sReturn = sReturn & "" Next sReturn = sReturn & "
Database FieldForm Field ValueData TypeRequiredError Message
 
" & aElement(0) & "" & Request.Form(aElement(1)) & "" & aElement(2) & "" & aElement(3) & "" & aElement(4) & "" & aElement(0) & "" & StripVar(aElement(1), "", NULL) & "" & aElement(2) & "" & aElement(3) & "" & aElement(4) & "
" sReturn = sReturn & "
" d sReturn, iOption End Function '################################################# Function d(sString, iOption) '//Process: quick method for debugging scripts If (sString = "") Then sString = "(Null)" End If '-Check if allosed to execute If (bDAllowed) Then Select Case iOption Case 0 'write out string only Response.Write sString & "
" Case 1 'write out string and stop code Response.Write sString & "
" Response.End Case Else 'write out string only Response.Write sString End Select End If End Function '################################################# Function dTimerStart() '//Process: Start the timer by setting a session Session("debugTimer") = FormatDateTime(Now, vbLongTime) End Function '################################################# Function dTimerDisplay() '//Process: Display timer execution time d "Script Execution Time: " & DateDiff("s", Session("debugTimer"), FormatDateTime(Now, vbLongTime)) & " seconds", 0 End Function ''################################################# 'Function dItemDetails(item, sItem, iOption) ' '//Process: Go through all of the form item and display their details ' Response.Write "
Var: " & item & " Value: " & sItem & " Type: " & VarType(sItem) & "(" & TypeName(item) & ")" ' Response.Write "
Is Numeric: " & IsNumeric(sItem) ' Response.Write "
Is Date: " & IsDate(sItem) ''end response if needed 'If (iOption = 1) Then ' response.end 'End If 'End Function %> <% '************************************************** '//Script: '//Copyright: 2004-2006 Froya Limited. All rights reserved. ' No part of this code maybe used or altered without prior permission of the owner '//Created: 04/09/06 '//Modified: 05/09/06 '************************************************** 'NOTES ' render stage 1 and 2 ' $render[] ' $renderD[] dynamic 'Function List ' renderTemplate(sTemplate) ' renderContent(sContent) ' renderParse(sDocument) '################################################## Function renderTemplate(sTemplate) '//Process: Render the template '//Param: sTemplate = template file to use '//Return: rendered document '//Call: response.write RenderTemplate("tem.html", 0) '//Version: 1 '//Created: 04/09/2006 '//Modified:05/09/2006 '-VARS Dim oFS Dim sDocument : sDocument = "" '-PROCESS 'check for default template If (isNull(sTemplate)) Then sTemplate = Session("systemSiteDefaultTemplate") End If 'load template Set oFS = server.CreateObject("Scripting.FileSystemObject") Set oFile = oFS.GetFile(server.mapPath(sTemplate)) Set oTextStream = oFile.OpenAsTextStream(1, -2) 'parse the page template sDocument = renderParse(oTextStream.ReadAll) '-replace content location sThemePath = Left(sTemplate, InStrRev(sTemplate, "/")) 'get theme path sDocument = Replace(sDocument, "src=""assets/", "src=""" & sThemePath & "assets/") 'replace images path sDocument = Replace(sDocument, " <% '************************************************** '//Script: Access Database Functions '//Copyright: 2004-2006 Froya Limited. All rights reserved. ' No part of this code maybe used or altered without prior permission of the owner '//Created: 19/07/2006 CC '//Modified: 28/09/2006 CC '************************************************** 'Requires ' inc_errors ' inc_dateTime 'Function List ' dbOpenConn ' dbOpenRS ' dbExecute ' dbOpenSchema ' dbUpdateRecord ' dbFieldExists ' dbColumnExists ' dbTableExists ' dbTableType ' dbGetValue ' dbFix ' dbNewID 'notes ' open a connection per script, not per recordset call '################################################## Function dbOpenConn(sDatabasePath) '//Process: Open and return a database connection '//Param: sDatabasePath = the path of the database to open '//Return: Opened connection '//Call: Set oConn = dbOpenConn("*.mdb") '//Version: 1 '//Created: 19/07/06 CC '-VARS Dim oConn, oDsn '-PROCESS 'open the connection set oConn = Server.CreateObject("ADODB.Connection") oDsn = "PROVIDER=Microsoft.Jet.OLEDB.4.0;DATA SOURCE=" & sDatabasePath &";" oConn.open oDsn '-RETURN Set dbOpenConn = oConn End Function '################################################# Function dbOpenRS(oConn, sSql) '//Process: Open a recordset and return it '//Param: oConn = database connection ' sSql = SQL statement to open '//Return: The open recordset '//Call: Set oRS = dbOpenRS(oConn, sSql) '//Version: 1 '//Created: 19/07/06 CC '-VARS Dim oRSTemp '-PROCESS 'check SQL is not empty and ends with a ';' If (sSql <> "") Then If (InStr(sSql, ";") = 0) Then sSql = sSql & ";" End If 'add semicolon 'script catches errors On Error Resume Next 'open the recordset Set oRSTemp = Server.CreateObject("ADODB.recordset") 'create recordset oRSTemp.CursorType = 2 'cursor navigation type (2=dynamic) oRSTemp.CursorLocation = 3 'set cursor location (3 = client) oRSTemp.Open sSql, oConn 'perform open 'analyse any errors If (oConn.errors.count > 0) Then For Each error In oConn.errors Call errorTrap("Error [" & error.number & "] : " & error.description & " [SQL: " & sSql & "]") 'catch error Next End If '-RETURN Set dbOpenRS = oRSTemp 'return recordset Else 'SQL invalid errorTrap("No Executable SQL Given") 'catch error End If 'sSql = "" End Function '################################################# Function dbExecute(oConn, sSql) '//Process: Execure a SQL statement '//Param: oConn = database connection / sSql = SQL statement to execute '//Return: true/false '//Call: Call dbExecute(oConn, sSql) '//Version: 1 '//Created: 19/07/06 CC '-VARS Dim bReturn : bReturn = true '-PROCESS 'Check SQL is not empty and ends with a ';' If (sSql <> "") Then If (InStr(sSql, ";") = 0) Then sSql = sSql & ";" End If 'add semicolon 'script catches errors On Error Resume Next oConn.Execute(sSql) 'Execute the SQL 'analyse any errors If (oConn.errors.count > 0) Then For Each error In oConn.errors Call errorTrap("Error [" & error.number & "] : " & error.description & " [SQL: " & sSql & "]") 'catch error Next bReturn = false End If Else 'SQL invalid errorTrap("No Executable SQL Given") 'catch error bReturn = false End If 'sSql = "" '-RETURN dbExecute = bReturn End Function '################################################# Function dbOpenSchema(oConn, sQueryType, aCriteria) '//Process: Open a database schema '//Param: oConn = database connection ' sQueryType = type of schema to open ' aCriteria = criteria to return (array) '//Return: The open schema '//Call: Set oSchema = dbOpenSchema(oConn, sQueryType, aCriteria) '//Version: 1 '//Created: 19/07/06 CC '-PROCESS 'script catches errors On Error Resume Next 'open the schema Set oSchema = Server.CreateObject("ADODB.recordset") 'create schema Set oSchema = oConn.OpenSchema(sQueryType, aCriteria) 'open schema 'analyse any errors If (oConn.errors.count > 0) Then For Each error In oConn.errors Call errorTrap("Error [" & error.number & "] : " & error.description & " [SQL: " & sSql & "]") 'catch error Next End If '-RETURN Set dbOpenSchema = oSchema 'return schema End Function '################################################# Function dbUpdateRecord(oConn, sTable, sFieldName, sFieldValue) '//Process: Update a record in the table according to submitted form '//Param: oConn = database connection ' sTable = table name ' sFieldName = Field to match for query ' sFieldValue = Value to match with the given field '//Return: true/false (errors) '//Call: Call dbExecute(oConn, sSql) '//Version: 1 '//Created: 28/09/06 CC '//Modified:28/09/06 CC '-VARS Dim oRSTemp 'temp recordset Dim sSql 'sql to execute/build Dim iFieldCount : iFieldCount = 0 'cound fields in table Dim bErrorGlobal : bErrorGlobal = False 'hold database validation errors Dim bError : bError = False 'hold field loop error Dim iType 'hold field type Dim sField 'hold field name Dim sValue 'hold field value '-PROCESS 'get datatypes sSql = "SELECT * FROM [" & sTable & "] WHERE ([" & sFieldName & "] = " & sFieldValue & ");" Set oRSTemp = dbOpenRS(oConn, sSql) iFieldCount = oRSTemp.fields.count -1 'build sql sSql = "UPDATE [" & sTable & "] SET " 'loop through fields, validating data For i=0 to iFieldCount bError = False bNullValue = False iType = oRSTemp(i).Type sField = oRSTemp(i).Name sValue = Request.Form(sField) If (sField <> "ID") Then 'ID field cannot be unpdated 'add field and analyse datatype sSql = sSql & "[" & sField & "]=" Select Case iType 'NUMBER - LONG INT Case 2, 3: If (sValue <> "") Then sSql = sSql & "" & sValue & "" ElseIf (VarType(sValue) = 0) Then 'do nothing bNullValue = True ElseIf (sValue = "") then sSql = sSql & "Null" Else errorTrapObject(sField) 'trap field associated with the error Call errorTrap("You did not enter a numeric value for the field " & fx_getExtensionValue(sTable, sField, 7)) bError = True End If 'NUMBER - BYTE Case 17: 'this datatype also carries the logical ext field If (fx_getExtensionData(sTable, sField, 2) = "Logical") Then If (sValue <> "") Then sSql = sSql & "1" Else sSql = sSql & "0" End If ElseIf (VarType(sValue) = 0) then sSql = sSql & "Null" ElseIf (sValue <> "") Then sSql = sSql & "" & sValue & "" Else errorTrapObject(sField) 'trap field associated with the error Call errorTrap("You did not enter a numeric value for the field " & fx_getExtensionValue(sTable, sField, 7)) bError = True End If 'NUMBER - DOUBLE Case 5: If (IsNumeric(sValue)) Then sSql = sSql & "" & sValue & "" ElseIf (sValue = "") then sSql = sSql & "Null" Else errorTrapObject(sField) 'trap field associated with the error Call errorTrap("You did not enter a numeric value for the field " & fx_getExtensionValue(sTable, sField, 7)) bError = True End If 'TEXT Case 202: If (InStr(Request.Form, sField & "=") = 0) Then 'check for null value except for logical fields bNullValue = True Else sSql = sSql & "'" & dbFix(sValue) & "'" End If 'MEMO Case 203: If (InStr(Request.Form, sField & "=") = 0) Then 'check for null value except for logical fields bNullValue = True Else sSql = sSql & "'" & dbFix(sValue) & "'" End If 'DATE / TIME Case 7: If (IsDate(sValue)) Then sSql = sSql & "#" & dateTimeConvert(sValue, "IS") & "#" 'dd/mm/yyyy -> yyyy/mm/dd ElseIf (sValue = "") then sSql = sSql & "Null" Else errorTrapObject(sField) 'trap field associated with the error Call errorTrap("You did not enter a proper date for the field " & fxFormatExtFieldName(sTable, sField, False)) bError = True End If 'CURRENCY Case 6: sValue = Replace(sValue , "£", "") 'strip pound sign If (IsNumeric(sValue)) Then sSql = sSql & "" & sValue & "" ElseIf (sValue = "") then sSql = sSql & "Null" Else errorTrapObject(sField) 'trap field associated with the error Call errorTrap("You did not enter a numeric value for the field " & fx_getExtensionValue(sTable, sField, 7)) bError = True End If Case Else: 'NOTHING End Select 'iType 'if null or an error, remove from the query If (bNullValue) then sSql = Replace(sSql, "[" & sField & "]=", "") 'remove field from sql ElseIf (bError) then sSql = Replace(sSql, "[" & sField & "]=", "") 'remove field from sql bErrorGlobal = True 'generate error Else sSql = sSql & ", " End If bError = False 'reset error catch End If 'if not ID Next 'Field 'prepare SQL and where clause sSql = Left(sSql, Len(sSql)-2) & " " sSql = sSql & "WHERE (" & sFieldName & " = " & sFieldValue & ");" ' d sSql,1 On Error Resume Next Call dbExecute(oConn, sSql) 'set last table and ID for later use Session("dbLastTable") = sTable Session("dbLastID") = sFieldValue '-RETURN If (oConn.Errors.Count = 0) And (bErrorGlobal = False) Then 'success Call messageTrap("Record Updated Successfully") 'catch message dbUpdateRecord = True Else 'errors dbUpdateRecord = False End if End Function '################################################# Function dbInsertRecord(oConn, sTable) '//Process: Update a record in the table according to submitted form '//Param: oConn = database connection ' sTable = table name '//Return: true/false (errors) '//Call: Call dbInsertRecord(oConn, "product") '//Version: 1 '//Created: 28/09/06 CC '//Modified:28/09/06 CC '????? - implement auto ID lookup system using IDLog '-VARS Dim oRSTemp 'temp recordset Dim sSql 'sql to execute/build Dim iFieldCount : iFieldCount = 0 'cound fields in table Dim bErrorGlobal : bErrorGlobal = False 'hold database validation errors Dim bError : bError = False 'hold field loop error Dim iType 'hold field type Dim sField 'hold field name Dim sValue 'hold field value Dim sSqlFields : sSqlFields = "" 'hold fields to insert Dim sSqlValues : sSqlValues = "" 'hold values to insert '-PROCESS 'get datatypes sSql = "SELECT TOP 1 * FROM [" & sTable & "];" Set oRSTemp = dbOpenRS(oConn, sSql) iFieldCount = oRSTemp.fields.count -1 'loop through fields, validating data For i=0 to iFieldCount bError = False bNullValue = False iType = oRSTemp(i).Type sField = oRSTemp(i).Name sValue = Request.Form(sField) If (sField <> "ID") Then 'ID field cannot be unpdated 'analyse datatype Select Case iType 'NUMBER - LONG INT Case 2, 3: sValue = Replace(sValue , "£", "") 'strip pound sign If (sValue <> "") Then sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "" & sValue & "," ElseIf (VarType(sValue) = 0) Then 'do nothing bNullValue = True ElseIf (sValue = "") then sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "NULL," Else errorTrapObject(sField) 'trap field associated with the error Call errorTrap("You did not enter a numeric value for the field " & fx_getExtensionValue(sTable, sField, 7)) bError = True End If 'NUMBER - BYTE Case 17: sValue = Replace(sValue , "£", "") 'strip pound sign 'this datatype also carries the logical ext field If (fx_getExtensionData(sTable, sField, 2) = "Logical") Then If (sValue <> "") Then sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "1," Else sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "0," End If ElseIf (VarType(sValue) = 0) then sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "NULL," ElseIf (sValue <> "") Then sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "" & sValue & "," Else errorTrapObject(sField) 'trap field associated with the error Call errorTrap("You did not enter a numeric value for the field " & fx_getExtensionValue(sTable, sField, 7)) bError = True End If 'NUMBER - DOUBLE Case 5: sValue = Replace(sValue , "£", "") 'strip pound sign If (IsNumeric(sValue)) Then sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "" & sValue & "," ElseIf (sValue = "") then sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "NULL," Else errorTrapObject(sField) 'trap field associated with the error Call errorTrap("You did not enter a numeric value for the field " & fx_getExtensionValue(sTable, sField, 7)) bError = True End If 'TEXT Case 202: If (InStr(Request.Form, sField & "=") = 0) Then 'check for null value except for logical fields bNullValue = True Else sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "'" & dbFix(sValue) & "'," End If 'MEMO Case 203: If (InStr(Request.Form, sField & "=") = 0) Then 'check for null value except for logical fields bNullValue = True Else sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "'" & dbFix(sValue) & "'," End If 'DATE / TIME Case 7: If (IsDate(sValue)) Then sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "#" & dateTimeConvert(sValue, "IS") & "#," 'dd/mm/yyyy -> yyyy/mm/dd ElseIf (sValue = "") Then sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "NULL," Else errorTrapObject(sField) 'trap field associated with the error Call errorTrap("You did not enter a proper date for the field " & fxFormatExtFieldName(sTable, sField, False)) bError = True End If 'CURRENCY Case 6: sValue = Replace(sValue , "£", "") 'strip pound sign If (IsNumeric(sValue)) Then sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "" & sValue & "," ElseIf (sValue = "") then sSqlFields = sSqlFields & "[" & sField & "]," sSqlValues = sSqlValues & "NULL," Else errorTrapObject(sField) 'trap field associated with the error Call errorTrap("You did not enter a numeric value for the field " & fx_getExtensionValue(sTable, sField, 7)) bError = True End If Case Else: 'NOTHING End Select 'iType 'if null or an error, remove from the query If (bError) then bErrorGlobal = True 'generate error End If bError = False 'reset error catch End If 'if not ID Next 'Field 'build sql sSql = "INSERT INTO [" & sTable & "] (" & Left(sSqlFields, Len(sSqlFields)-1) & ") VALUES (" & Left(sSqlValues, Len(sSqlValues)-1) & ");" ' d sSql,1 ' On Error Resume Next Call dbExecute(oConn, sSql) 'set last table and ID for later use sSql = "SELECT TOP 1 * FROM " & sTable & ";" Set oRSTemp = dbOpenRS(oConn, sSql) sSql = "SELECT Max(" & oRSTemp(0).Name & ") As lastID FROM " & sTable & ";" Set oRSTemp = dbOpenRS(oConn, sSql) Session("dbLastTable") = sTable Session("dbLastID") = oRSTemp("lastID") Set oRSTemp = Nothing '-RETURN If (oConn.Errors.Count = 0) And (bErrorGlobal = False) Then 'success Call messageTrap("Record Added Successfully") 'catch message dbInsertRecord = True Else 'errors dbInsertRecord = False End if End Function '################################################# Function dbDeleteRecord(oConn, sTable) '//Process: Delete a record(s) '//Param: oConn = database connection ' sTable = table to delete record(s) from '//Return: true/false '//Call: Call dbDeleteRecord(oConn, sTable) '//Version: 1 '//Created: 29/07/06 CC '//Modified: 29/07/06 CC '-VARS Dim sSql : sSql = "" 'sql '-PROCESS and RETURN On Error Resume Next If (Request.Form("selectedID") = "") Then 'nothing selected Call errorTrap("No records were selected to delete.") dbDeleteRecord = False Else 'continue with delete 'get the ID field name If (Request.Form("field") <> "") Then sIDField = "[" & Request.Form("field") & "]" Else sIDField = "[ID]" End If aCheckboxValues = Split(Request.Form("selectedID"), ",") 'get ID's to match sSql = "DELETE FROM [" & sTable & "] WHERE (" For i=0 To Ubound(aCheckboxValues) sSql = sSql & "(" & sIDField & " = " & aCheckboxValues(i) & ") OR " Next sSql = Left(sSql, Len(sSql)-4) sSql = sSql & ");" Call dbExecute(oConn, sSql) If (oConn.errors.count > 0) Then For Each error In oConn.errors Call errorTrap("Error [" & error.number & "] : " & error.description & " [SQL: " & sSql & "]") 'catch error Next dbDeleteRecord = False Else 'get number deleted If ((Ubound(aCheckboxValues)+1) > 1) Then messageTrap("Records Deleted Successfully") Else messageTrap("Record Deleted Successfully") End If dbDeleteRecord = True End If 'errors End If 'toggle check End Function '################################################# Function dbFieldExists(oRS, sField) '//Process: Check that the item is a field in the database '//Param: oRS = recordset to search ' sField = field to look for '//Return: true/false '//Call: If (dbFieldExists(oRS, "field")) Then ... '//Version: 1 '//Created: 19/07/06 CC '-PROCESS '-Check for NULL oRS If (IsNull(oRS)) Then DBFieldExists = False Exit Function End If 'Loop through all DB table fields For Each field in oRS.fields If (field.name = sField) Then 'return match found DBFieldExists = True Exit Function End If Next 'field '-RETURN DBFieldExists = False 'default false send back End Function '################################################## Function dbColumnExists(sTable, sColumn, oConn) '//Process: Check if a column exists in the given table/connection '//Param: sTable = Table to check in ' sColumn = Column to search for ' oConn = Connection to look in. If NULL then open a new connection '//Return: Exists: True|False '//Call: If (dbColumnExists(sTable, sColumn, oConn) '//Version: 1 '//Created: 19/07/06 CC '-VARS Dim bExists : bExists = False '-PROCESS 'check for connection If (IsNull(oConn)) Then Set oConn = dbOpenConn(Server.MapPath(db_sDatabasePath)) End If '-open recordset with columns schema aConstraints = Array(Empty,Empty,sTable,sColumn) 'catalog,schema,table,column Set oRS = oConn.OpenSchema(4,aConstraints) '4 = adSchemaColumns '-loop through tables and find a match Do While Not oRS.EOF '-check for match and act If (oRS("COLUMN_NAME") = sColumn) Then bExists = True End If oRS.MoveNext Loop Set oRS = Nothing '-RETURN dbColumnExists = bExists End Function '################################################## Function dbTableExists(sTable, oConn) '//Process: Check if a table exists in the given connection '//Param: sTable = Table to check in ' oConn = Connection to look in. If NULL then open a new connection '//Return: Exists: True|False '//Call: If (dbTableExists(sTable, oConn)) Then '//Version: 1 '//Created: 24/08/06 CC '-VARS Dim oRSTemp Dim bExists : bExists = False '-PROCESS 'check for connection If (IsNull(oConn)) Then Set oConn = dbOpenConn(Server.MapPath(db_sDatabasePath)) End If '-open recordset with columns schema aConstraints = Array(Empty,Empty,sTable,Empty) 'catalog,schema,table,type ' Set oRSTemp = oConn.OpenSchema(20,aConstraints) '20 = adSchemaTables Set oRSTemp = oConn.OpenSchema(20) '20 = adSchemaTables '-loop through tables and find a match Do While Not oRSTemp.EOF '-check for match and act If (oRSTemp("TABLE_NAME") = sTable) Then bExists = True End If oRSTemp.MoveNext Loop Set oRSTemp = Nothing '-RETURN dbTableExists = bExists End Function '################################################## Function dbTableType(sTable, oConn) '//Process: Check a table type '//Param: sTable = Table to check in ' oConn = Connection to look in. If NULL then open a new connection '//Return: table type '//Call: If (dbTableType(sTable, oConn) = "table") Then '//Version: 1 '//Created: 24/08/06 CC '-VARS Dim sReturn : sReturn = NULL '-PROCESS 'check for connection If (IsNull(oConn)) Then Set oConn = dbOpenConn(Server.MapPath(db_sDatabasePath)) End If '-open recordset with tables schema Set oRSTemp = oConn.OpenSchema(20) '20 = adSchemaTables '-loop through tables and find a match Do While Not oRSTemp.EOF '-check for match and act If (oRSTemp("TABLE_NAME") = sTable) Then sReturn = oRSTemp("TABLE_TYPE") End If oRSTemp.MoveNext Loop Set oRSTemp = Nothing '-RETURN dbTableType = sReturn End Function '################################################## Function dbGetValue(oConn, sSql) '//Process: Execute an SQL statement and return the first value returned '//Param: oConn = Connection to look in. If NULL then open a new connection ' sSql = SQL to execute and get value from '//Return: value returned or null '//Call: Response.Write dbGetValue("SELECT value FROM table WHERE val=val;", oConn) '//Version: 1 '//Created: 19/09/06 CC '-VARS Dim sReturn : sReturn = "" Dim oRSTemp '-PROCESS On Error Resume Next 'check for connection Set oRSTemp = dbOpenRS(oConn, sSql) If (Not oRSTemp.EOF) Then sReturn = oRSTemp(0).Value End If Set oRSTemp = Nothing '-RETURN dbGetValue = sReturn End Function '################################################ Function dbFix(sValue) '//Process: Fix a record valud ready to insert into the database '//Param: sValud = value to fix '//Return: value returned '//Call: sValue = dbFix(sValue) '//Version: 1 '//Created: 28/09/06 CC '-VARS Dim sReturn : sReturn = sValue '-PROCESS ' sReturn = Replace(sValue,"!", " ") '????? sReturn = Replace(sReturn,"'", "''") '-RETURN dbFix = sReturn End Function '################################################# Function dbNewID(oConn, sRef) '//Process: Get a new ID from the ID log '//Param: sRef = ID Log Reference '//Return: value returned '//Call: sValue = dbNewID("fieldName") '//Version: 1 '//Created: 05/10/06 CC '-VARS Dim iReturn : iReturn = 0 'default as 1 because 0 is used for null ID's Dim oRSTemp '-PROCESS sSql = "SELECT " & sRef & " AS TopID FROM [IDLog];" Set oRSTemp = dbOpenRS(oConn, sSql) If (oRSTemp.RecordCount <> 0) Then iReturn = oRSTemp("TopID") sSql = "UPDATE [IDLog] SET " & sRef & "=" & sRef & "+1;" Call dbExecute(oConn, sSql) End If 'check that the recoird count starts at 1 If (iReturn = 0) Then iReturn = 1 sSql = "UPDATE [IDLog] SET " & sRef & "=2;" Call dbExecute(oConn, sSql) End If '-RETURN dbNewID = iReturn End Function %> <% '************************************************** '//Script: '//Copyright: 2004-2006 Froya Limited. All rights reserved. ' No part of this code maybe used or altered without prior permission of the owner '//Created: 30/08/06 '//Modified: 30/08/06 '************************************************** 'Function List ' cacheGetFileName() ' cacheValid() ' cacheLoad() ' cacheSave(sDataToCache) ' cacheClearAll() ' cacheClearPage() '-GLOBAL VARIABLES Dim cache_iPeriod : cache_iPeriod = 60 'cache interval Dim cache_sInterval : cache_sInterval = "s" 'cache interval period (s=seconds) Dim cache_sFolderPath : cache_sFolderPath = "cache" 'cache directory '################################################## Function cacheGetFileName() '//Process: Generate the cache filename to look for from the current script '//Return: Filename to retrieve '//Call: sFilename = cacheGetFileName() '//Version: 1 '//Created: 30/08/06 '//Modified:30/08/06 '-VARS Dim sScriptFileName, sQueryString, sReturn '-PROCESS 'generate unique file name from script and querystring sScriptFileName = Request.ServerVariables("url") sScriptFileName = Right(sScriptFileName, Len(sScriptFileName) - InStrRev(sScriptFileName, "/")) & sQueryString sQueryString = Request.ServerVariables("query_string") If (sQueryString <> "") Then sReturn = sScriptFileName & "-" & sQueryString Else sReturn = sScriptFileName End if 'replace illegal characters sReturn = Replace(sReturn, " ", "_") sReturn = Replace(sReturn, "%20", "_") sReturn = Replace(sReturn, "?", "") sReturn = Replace(sReturn, "/", "") sReturn = Replace(sReturn, "\", "") sReturn = Replace(sReturn, """", "") sReturn = Replace(sReturn, ":", "") sReturn = Replace(sReturn, "*", "") sReturn = Replace(sReturn, ">", "") sReturn = Replace(sReturn, "<", "") 'add cache folder path sReturn = cache_sFolderPath & "/" & sReturn & ".cache" '-RETURN cacheGetFileName = sReturn End Function '################################################## Function cacheValid() '//Process: Return if the cache file is valid (via name and age) '//Return: True / False '//Call: If (cacheValid()) Then '//Version: 1 '//Created: 30/08/06 '//Modified:30/08/06 '-VARS Dim oFS, sReturn '-PROCESS Set oFs = Server.CreateObject("Scripting.FileSystemObject") 'check cache exists and is not too long If (Len(cacheGetFileName()) > 170) Then 'cache file too long to so will not be have been cached sReturn = False ElseIf (oFS.FileExists(Server.MapPath(cacheGetFileName()))) Then Set oFile = oFS.GetFile(Server.MapPath(cacheGetFileName())) ' d "Cache last modified: " & oFile.DateLastModified,0 ' d "Cache period: " & cache_iPeriod & cache_sInterval,0 'check age of cache If (DateDiff(cache_sInterval, oFile.DateLastModified, Now()) >= cache_iPeriod) Then 'file old ' d "Cache expired: " & DateDiff(cache_sInterval, oFile.DateLastModified, Now()) & cache_sInterval,0 sReturn = False Else 'cache within period ' d "Cache fresh: " & cache_iPeriod - DateDiff(cache_sInterval, oFile.DateLastModified, Now()) & cache_sInterval & " until expiry",0 sReturn = True End If Else 'file not exist ' d "Cache not exist",0 sReturn = False End If '-RETURN 'return cached data if exist Set oFS = Nothing cacheValid = sReturn End Function '################################################## Function cacheLoad() '//Process: Loads a cache file and returns it's contents '//Return: cache file contents '//Call: sFile = cacheLoad() '//Version: 1 '//Created: 30/08/06 '//Modified:30/08/06 '-VARS Dim oFS, oFile, oTextStream, dExpires '-PROCESS ' d "Loading from cache: " & cacheGetFileName(),0 Set oFs = Server.CreateObject("Scripting.FileSystemObject") Set oFile = oFS.GetFile(Server.MapPath(cacheGetFileName())) Set oTextStream = oFile.OpenAsTextStream(1, -2) sReturn = oTextStream.ReadAll 'set expiry response headers dExpires = DateAdd(cache_sInterval, cache_iPeriod, Now()) Response.ExpiresAbsolute = Month(dExpires) & " " & Day(dExpires) & " " & Year(dExpires) & " " & FormatDateTime(dExpires, 3) Response.CacheControl = "Public" '-RETURN 'return cached data if exist Set oTextStream = Nothing Set oFile = Nothing Set oFS = Nothing cacheLoad = sReturn End Function '################################################## Function cacheSave(sDataToCache) '//Process: Save the data to cache to file '//Param: sDataToCache : The data to cache '//Call: Call cacheSave(sDataToCache) '//Version: 1 '//Created: 30/08/06 '//Modified:30/08/06 '-VARS Dim oFS, oTextStream '-PROCESS If (cache_iPeriod > 0) Then 'can cache 'compress data sTemp = sDataToCache sTemp = Replace(sTemp, VbCrLf, " ") sTemp = Replace(sTemp, VbTab, " ") For i = 1 To Len(sTemp) sCh = Mid(sTemp,i,1) 'look at each character in turn 'if the chr is a space and the previous added chr was a space ignore it 'otherwise add it on If Not (sCh = " " and Right(sOut,1) = " ") Then sOut = sOut & sCh End If Next sDataToCache = sOut 'check cahce file name lenght If (Len(cacheGetFileName()) > 170) Then 'cache file too long to save ' d "Cache file to long: " & Len(cacheGetFileName()),0 Else 'save data to cache to cache folder ' d "Saving to cache: " & cacheGetFileName(),0 Set oFs = Server.CreateObject("Scripting.FileSystemObject") Set oTextStream = oFS.OpenTextFile(Server.MapPath(cacheGetFileName()), 2, true) oTextStream.Write (sDataToCache) Set oTextStream = Nothing Set oFS = Nothing End If End If End Function '################################################## Function cacheClearAll() '//Process: Delete all of the cache files in the cache filder '//Call: Call cacheClearAll() '//Version: 1 '//Created: 30/08/06 '//Modified:30/08/06 '-VARS Dim Fs, oFsFolder, oFsFile '-PROCESS 'delete all cache files ' d "Clearing cache: All pages",0 Set oFs = Server.CreateObject("Scripting.FileSystemObject") Set oFsFolder = oFs.GetFolder(Server.MapPath(cache_sFolderPath)) For Each oFsFile In oFSFolder.Files If (InStr(oFsFile.Name, ".cache") > 0) Then oFsFile.Delete End If Next '-RETURN Set oFsFile = Nothing Set oFsFolder = Nothing Set oFS = Nothing End Function '################################################## Function cacheClearPage() '//Process: Clear the cache for a single page '//Call: Call cacheClearPage() '//Version: 1 '//Created: 30/08/06 '//Modified:30/08/06 '-VARS Dim sScriptFileName, oFs, oFsFolder, oFsFile '-PROCESS 'delete all cache files sScriptFileName = Right(Request.ServerVariables("url"), Len(Request.ServerVariables("url")) - InStrRev(Request.ServerVariables("url"), "/")) ' d "Clearing cache: " & sScriptFileName & " cache only",0 Set oFs = Server.CreateObject("Scripting.FileSystemObject") Set oFsFolder = oFs.GetFolder(Server.MapPath(cache_sFolderPath)) For Each oFsFile In oFSFolder.Files If ((InStr(oFsFile.Name, ".cache") > 0) And (InStr(oFsFile.Name, sScriptFileName) > 0)) Then oFsFile.Delete End If Next Set oFsFile = Nothing Set oFsFolder = Nothing Set oFS = Nothing End Function %> <% '************************************************** '//Script: Shopping Cart Component '//Copyright: 2004-2006 Froya Limited. All rights reserved. ' No part of this code maybe used or altered without prior permission of the owner '//Created: 15/08/2006 CC '//Modified: 24/10/2006 CC '************************************************** 'Requires ' inc_dbAccess.asp or inc_dbMsSQL 'Function List ' cartAddItem(oConn) ' cartRemoveItem(oConn) ' cartUpdateItem(oConn) ' cartDisplay(oConn, iDisplay) ' cartSummary(iDisplay) ' cartMenu ' cartSetDiscountPercent(iValue) ' cartSetDiscountPrice(iValue) ' PcartCalculateTotal(oConn) ' cartEmpty ' cartSaveToDatabase(oConn) ' cartLoadFromDatabase(oConn) 'Session Array Layout ' FroyaCart : ' (0) = Total Items ' (1) = Total Price ' (2) = Total Weight ' (3) = Total Delivery ' (5) = Discount Price ' (4) = Discount Percent ' (6) = Grand Total ' FroyaCartItem[] : ' (0) = product ID ' (1) = Product Title ' (2) = Quantity ' (3) = Product Price ' (4) = Weight ' (5) = Product Delivery ' (6) = Sub Total (Quantity * Product Price) ' (7) = Special Field 'Variables Dim cart_productID : cart_productID = "productID" 'product ID field Dim cart_productTitle : cart_productTitle = "title" 'product title field Dim cart_productDescription : cart_productDescription = "description" 'product description field Dim cart_productPrice : cart_productPrice = "priceIncVat" 'product price field Dim cart_productWeight : cart_productWeight = "weight" 'product weight [new] Dim cart_productDiscount : cart_productDiscount = "" 'product discount field Dim cart_productSalePrice : cart_productSalePrice = "discountPriceIncVat" 'product sale price field Dim cart_productDeliveryPrice : cart_productDeliveryPrice = "" 'product delivery price Dim cart_productTable : cart_productTable = "product" 'product table Dim cart_deleteButtonValue : cart_deleteButtonValue = "" 'delete button value in the basket detail form '################################################## Function cartAddItem(oConn) '//Process: Add an item to the cart, or increment the quantity '//Param: oConn : Database Connection '//Call: cartAddItem() '//Version: 1 '//Created: 15/08/2006 CC '//Modified:20/09/06 '-VARS Dim sSpecialField : sSpecialField = "" 'special field definition Dim sExtra : sExtra = "" 'extra field for discount or sale price Dim sDelivery : sDelivery = "" 'field to hold the delivery price for the array Dim iDelivery : iDelivery = 0 'hold the delivery for the item Dim sWeight : sWeight = "" 'field to hold the weight Dim iWeight : iWeight = 0 'hold the weight for the item Dim iPrice : iPrice = 0 'hold the price with any discounts applied Dim oRSTemp '-PROCESS 'validate input If (IsNumeric(Request.Form("ID")) AND IsNumeric(Request.Form("quantity"))) Then If (Int(Request.Form("quantity")) > 0) Then 'get product details sSql = "SELECT DISTINCT specialField FROM [cartSettings];" Set oRSTemp = dbOpenRS(oConn, sSql) If (Not oRSTemp.EOF) Then If (oRSTemp("specialField") <> "") Then sSpecialField = ", " & oRSTemp("specialField") End If End If 'special field sSql = "SELECT DISTINCT deliveryRanges FROM [cartSettings];" Set oRSTemp = dbOpenRS(oConn, sSql) If (Not oRSTemp.EOF) Then If (oRSTemp("deliveryRanges") = 0) Then 'check for usage of ranges 'use product not ranges If (dbColumnExists(cart_productTable, cart_productDeliveryPrice, oConn)) Then 'check delivery price exists sDelivery = ", " & cart_productDeliveryPrice End If End If 'range check End If 'delivery field 'check for weight If (dbColumnExists(cart_productTable, cart_productWeight, oConn)) Then sWeight = ", " & cart_productWeight End If 'check for discount or sale price If (dbColumnExists(cart_productTable, cart_productDiscount, oConn)) Then sExtra = ", " & cart_productDiscount ElseIf (dbColumnExists(cart_productTable, cart_productSalePrice, oConn)) Then sExtra = ", " & cart_productSalePrice End If 'col exists sSql = "SELECT DISTINCT " & cart_productID & ", " & cart_productTitle & ", " & cart_productPrice & " " & sSpecialField & sExtra & sDelivery & sWeight & " FROM [" & cart_productTable & "] WHERE " & cart_productID & "=" & Request.Form("ID") & ";" Set oRSTemp = dbOpenRS(oConn, sSql) If (Not oRSTemp.EOF) Then 'get extra field to validate price If (Mid(sExtra,3) = cart_productDiscount) Then iPrice = oRSTemp(cart_productPrice) - oRSTemp(cart_productDiscount) ElseIf (Mid(sExtra,3) = cart_productSalePrice) Then If (oRSTemp(cart_productSalePrice) > 0) Then iPrice = oRSTemp(cart_productSalePrice) Else iPrice = oRSTemp(cart_productPrice) End If Else iPrice = oRSTemp(cart_productPrice) End If 'sExtra check 'get delivery if needed If (sDelivery <> "") Then iDelivery = oRSTemp(cart_productDeliveryPrice) End If 'get weight if needed If (sWeight <> "") Then iWeight = oRSTemp(cart_productWeight) End If 'check if product already in session If (IsArray(Session("FroyaCartItem[" & Request.Form("ID") & "]"))) Then 'increment quantity aSession = Session("FroyaCartItem[" & Request.Form("ID") & "]") Session("FroyaCartItem[" & Request.Form("ID") & "]") = Array(Request.Form("ID"), Replace(oRSTemp(cart_productTitle), "'", "''"), Int(aSession(2)) + Int(Request.Form("quantity")), FormatNumber(iPrice, 2,,,0), iWeight, iDelivery, FormatNumber(Int(aSession(2) + Request.Form("quantity")) * iPrice,2,,,0), Mid(Replace(oRSTemp(Mid(sSpecialField,3)), "'", "''"),1,100)) Else 'create array Session("FroyaCartItem[" & Request.Form("ID") & "]") = Array(Request.Form("ID"),Replace(oRSTemp(cart_productTitle), "'", "''"), Int(Request.Form("quantity")), FormatNumber(iPrice, 2,,,0), iWeight, iDelivery, FormatNumber(Int(Request.Form("quantity")) * iPrice,2,,,0), Mid(Replace(oRSTemp(Mid(sSpecialField,3)), "'", "''"),1,100)) End If 'array exists check End If 'product recordcount End If 'quantity numeric End If 'valid form fields 'update totals Call PcartCalculateTotal(oConn) End Function '################################################## Function cartRemoveItem(oConn) '//Process: Remove an item from the cart '//Param: oConn : database connection '//Call: cartRemoveItem() '//Version: 1 '//Created: 15/08/2006 CC '-PROCESS 'validate input If (IsNumeric(Request.Form("ID"))) Then 'remove product If (IsArray(Session("FroyaCartItem[" & Request.Form("ID") & "]"))) Then 'remove product Session.Contents.Remove("FroyaCartItem[" & Request.Form("ID") & "]") End If 'valid cart array End If 'valid form field 'update totals Call PcartCalculateTotal(oConn) End Function '################################################## Function cartUpdateItem(oConn) '//Process: Update an items quantity or delete it if the new quantity is 0 '//Param: oConn : database connection '//Call: cartUpdateItem() '//Version: 1 '//Created: 15/08/2006 CC '-PROCESS 'validate input If (IsNumeric(Request.Form("ID")) AND IsNumeric(Request.Form("quantity"))) Then 'check quantity If (Int(Request.Form("quantity")) > 0) Then 'update quantity If (IsArray(Session("FroyaCartItem[" & Request.Form("ID") & "]"))) Then 'increment quantity aSession = Session("FroyaCartItem[" & Request.Form("ID") & "]") Session("FroyaCartItem[" & Request.Form("ID") & "]") = Array(Request.Form("ID"), aSession(1), Int(Request.Form("quantity")), aSession(3), aSession(4), aSession(5), FormatNumber(Int(Request.Form("quantity")) * aSession(3),2,,,0), aSession(7)) End If 'valid cart array ElseIf (Int(Request.Form("quantity")) = 0) Then 'remove product If (IsArray(Session("FroyaCartItem[" & Request.Form("ID") & "]"))) Then 'remove product Session.Contents.Remove("FroyaCartItem[" & Request.Form("ID") & "]") End If 'valid cart array End If 'quantity check End If 'valid form fields 'update totals Call PcartCalculateTotal(oConn) End Function '################################################## Function cartDisplay(oConn, iDisplay) '//Process: Display the cart contents with editable options '//Param: oConn : database connection ' iDisplay = Display default titles, or holders for custom ones ' 0: display default titles ' 1: display custom place holders '//Return: Cart output table '//Call: Response.Write cartDisplay() '//Version: 1 '//Created: 15/08/2006 CC '//Modified:20/09/06 '-VARS Dim sReturn : sReturn = "" Dim sDetailScript : sDetailScript = "" Dim oRSTemp '-PROCESS On Error Resume Next 'only display if there are items If (IsEmpty(Session("FroyaCart")(0)) Or (Session("FroyaCart")(0) = 0)) Then 'raise error to say basket is empty Call messageTrap("Your basket is empty.") cartSummary = sReturn Exit Function End If sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf 'check default display If (iDisplay = 1) Then 'custom sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf Else 'default sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf End If 'get script to send title too sSql = "SELECT DISTINCT detailScript FROM [cartSettings];" Set oRSTemp = dbOpenRS(oConn, sSql) If (Not oRSTemp.EOF) Then If (oRSTemp("detailScript") <> "") Then sDetailScript = oRSTemp("detailScript") End If End If Set oRSTemp = Nothing 'list items For Each oSession In Session.Contents() 'loop through all sessions If (Mid(oSession, 1, 13) = "FroyaCartItem") Then 'if froya cart aSession = Session(oSession) 'save session to variable sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf If (sDetailScript = "") Then sReturn = sReturn & " " & vbCrLf Else sReturn = sReturn & " " & vbCrLf End If 'script check sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf End If Next 'oSession 'show delivery if needed If (Session("FroyaCart")(3) > 0) Then sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf End If 'delivery display check 'discount price check If (Session("FroyaCart")(4) > 0) Then sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf End If 'discount price check 'discount percent check If (Session("FroyaCart")(5) > 0) Then sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf End If 'discount price check sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & "
TitlePriceQuantity

" & aSession(1) & "

" & aSession(7) & "

" & aSession(1) & "

" & aSession(7) & "

£" & FormatNumber(aSession(3),2,,,0) & "" & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & "
Sub Total£" & FormatNumber(Session("FroyaCart")(1),2,,,0) & "
Delivery£" & FormatNumber(Session("FroyaCart")(3),2,,,0) & "
Discount£" & FormatNumber(Session("FroyaCart")(4),2,,,0) & "
Discount" & FormatNumber(Session("FroyaCart")(5),2,,,0) & "%
Total£" & FormatNumber(Session("FroyaCart")(6),2,,,0) & "
" & vbCrLf '-RETURN cartDisplay = sReturn End Function '################################################## Function cartSummary(iDisplay) '//Process: Display a cart summary, listing items, quantities and totals '//Params: iDisplay = Display default titles, or holders for custom ones ' 0: display default titles ' 1: display custom place holders '//Return: Cart summary output table '//Call: Response.Write cartSummary() '//Version: 1 '//Created: 16/08/2006 CC '-VARS Dim sReturn : sReturn = "" '-PROCESS On Error Resume Next 'only display if there are items If (IsEmpty(Session("FroyaCart")(0)) Or (Session("FroyaCart")(0) = 0)) Then cartSummary = sReturn Exit Function End If sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf 'check default display If (iDisplay = 1) Then 'custom sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf Else 'default sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf End If 'list items For Each oSession In Session.Contents() 'loop through all sessions If (Mid(oSession, 1, 13) = "FroyaCartItem") Then 'if froya cart aSession = Session(oSession) 'save session to variable sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf End If Next 'oSession 'show delivery if needed If (Session("FroyaCart")(2) > 0) Then sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf End If 'delivery display check 'discount price check If (Session("FroyaCart")(4) > 0) Then sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf End If 'discount price check 'discount percent check If (Session("FroyaCart")(5) > 0) Then sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf End If 'discount price check sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & "
TitlePriceQuantity

" & aSession(1) & "

" & aSession(7) & "

£" & FormatNumber(aSession(3),2,,,0) & "" & aSession(2) & "
Sub Total£" & FormatNumber(Session("FroyaCart")(1),2,,,0) & "
Delivery£" & FormatNumber(Session("FroyaCart")(3),2,,,0) & "
Discount£" & FormatNumber(Session("FroyaCart")(4),2,,,0) & "
Discount" & FormatNumber(Session("FroyaCart")(5),2,,,0) & "%
Total£" & FormatNumber(Session("FroyaCart")(6),2,,,0) & "
" & vbCrLf '-RETURN cartSummary = sReturn End Function '################################################## Function cartMenu() '//Process: Display the cart meny, showing items, total and cart button '//Return: Cart menu table '//Call: Response.Write cartMenu() '//Version: 1 '//Created: 16/08/2006 CC '-VARS Dim sReturn : sReturn = "" '-PROCESS sReturn = sReturn & " " & vbCrLf 'show delivery if needed On Error Resume Next sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf 'delivery check If (Session("FroyaCart")(2) > 0) Then sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf End If 'delivery display check 'discount price check If (Session("FroyaCart")(4) > 0) Then sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf End If 'discount price check 'discount percent check If (Session("FroyaCart")(5) > 0) Then sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf End If 'discount price check sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & " " & vbCrLf sReturn = sReturn & "
Items" & Session("FroyaCart")(0) & "
Sub Total£" & FormatNumber(Session("FroyaCart")(1),2,,,0) & "
Delivery£" & FormatNumber(Session("FroyaCart")(2),2,,,0) & "
Discount£" & FormatNumber(Session("FroyaCart")(4),2,,,0) & "
Discount" & FormatNumber(Session("FroyaCart")(5),2,,,0) & "%
Total£" & FormatNumber(Session("FroyaCart")(3),2,,,0) & "
" & vbCrLf '-RETURN cartMenu = sReturn End Function '################################################## Function cartSetDiscountPrice(iValue) '//Process: Set the discount price value '//Call: Call cartSetDiscountPrice(20) '//Version: 1 '//Created: 08/11/2006 CC On Error Resume Next If (IsNumeric(iValue)) Then Session("FroyaCart") = Array(Session("FroyaCart")(0),Session("FroyaCart")(1),Session("FroyaCart")(2),Session("FroyaCart")(3),"" & iValue,Session("FroyaCart")(5),Session("FroyaCart")(6)) End If End Function '################################################## Function cartSetDiscountPercent(iValue) '//Process: Set the discount percent value '//Call: Call cartSetDiscountPercent(20) '//Version: 1 '//Created: 08/11/2006 CC On Error Resume Next If (IsNumeric(iValue)) Then Session("FroyaCart") = Array(Session("FroyaCart")(0),Session("FroyaCart")(1),Session("FroyaCart")(2),Session("FroyaCart")(3),Session("FroyaCart")(4),"" & iValue,Session("FroyaCart")(6)) End If End Function '################################################## Private Function PcartCalculateTotal(oConn) '//Process: Calculate the total of the cart to add to the main array '//Param: oConn : database connection '//Call: cartCalculateTotal() '//Version: 1 '//Created: 16/08/2006 CC '//Modified:20/09/06 '-VARS Dim iItems : iItems = 0 'total items Dim iPrice : iPrice = 0 'total price Dim iWeight : iWeight = 0 'total weight Dim iDelivery : iDelivery = 0 'total delivery Dim iDiscountPrice : iDiscountPrice = 0 'discount price Dim iDiscountPercent : iDiscountPercent = 0 'discount percent Dim iDeliveryCalculation : iDeliveryCalculation = 0 'how delivery is calculated Dim iGrandTotal : iGrandTotal = 0 'grand total for cart Dim oRSTemp '-PROCESS On Error Resume Next 'check delivery calculation sSql = "SELECT DISTINCT deliveryRanges FROM [cartSettings];" Set oRSoRSTemp = dbOpenRS(oConn, sSql) If (Not oRSoRSTemp.EOF) Then iDeliveryCalculation = oRSoRSTemp("deliveryRanges") 'set type field End If 'delivery field Set oRSoRSTemp = Nothing For Each oSession In Session.Contents() 'loop through all sessions If (Mid(oSession, 1, 13) = "FroyaCartItem") Then 'if froya cart aSession = Session(oSession) 'save session to variable 'check we can add it iItems = iItems + aSession(2) iPrice = iPrice + (aSession(3) * aSession(2)) If (aSession(4) <> "") Then iWeight = iWeight + (aSession(4) * aSession(2)) End If 'calculate delivery if to be done If (iDeliveryCalculation = 0) Then iDelivery = iDelivery + (aSession(5) * aSession(2)) End If End If Next 'oSession 'check range deivery If (iDeliveryCalculation = 1) Then 'Items sSql = "SELECT deliveryPrice FROM cartDeliveryRanges WHERE (valueFrom <= " & iItems & ") AND (valueTo > " & iItems & ");" Set oRSoRSTemp = dbOpenRS(oConn, sSql) If (Not oRSoRSTemp.EOF) Then iDelivery = oRSoRSTemp("deliveryPrice") End If 'items Set oRSoRSTemp = Nothing ElseIf (iDeliveryCalculation = 2) Then 'Price sSql = "SELECT deliveryPrice FROM cartDeliveryRanges WHERE (valueFrom <= " & iPrice & ") AND (valueTo > " & iPrice & ");" Set oRSoRSTemp = dbOpenRS(oConn, sSql) If (Not oRSoRSTemp.EOF) Then iDelivery = oRSoRSTemp("deliveryPrice") End If 'price Set oRSoRSTemp = Nothing ElseIf (iDeliveryCalculation = 3) Then 'Weight sSql = "SELECT deliveryPrice FROM cartDeliveryRanges WHERE (valueFrom <= " & iWeight & ") AND (valueTo > " & iWeight & ");" Set oRSoRSTemp = dbOpenRS(oConn, sSql) If (Not oRSoRSTemp.EOF) Then iDelivery = oRSoRSTemp("deliveryPrice") End If 'price Set oRSoRSTemp = Nothing End If 'check for discount price iDiscountPrice = Session("FroyaCart")(4) 'check for discount % iDiscountPercent = Session("FroyaCart")(5) 'calculate grand total iGrandTotal = ((((iPrice + iDelivery) - iDiscountPrice) / 100) * (100 - iDiscountPercent)) 'save to session Session("FroyaCart") = Array(iItems, iPrice, iWeight, iDelivery, iDiscountPrice, iDiscountPercent, iGrandTotal) End Function '################################################## Function cartEmpty() '//Process: empty the cart '//Call: Call cartEmpty() '//Version: 1 '//Created: 24/08/2006 CC '-PROCESS On Error Resume Next For iSessionCount = 1 To 5 'loop 5 times to get every session For Each oSession In Session.Contents() 'loop through all sessions If (Mid(oSession, 1, 13) = "FroyaCartItem") Then 'if froya cart item Session.Contents.Remove(oSession) End If If (Mid(oSession, 1, 9) = "FroyaCart") Then 'if froya cart Session.Contents.Remove(oSession) End If Next 'session Next 'cart loop End Function '################################################## Function cartSaveToDatabase(oConn, iID) '//Process: save the cart to the database '//Param: oConn : database connection ' iID = ID to give the cart '//Call: cartSaveToDatabase() '//Version: 1 '//Created: 16/08/2006 CC '-PROCESS On Error Resume Next 'save cart items For Each oSession In Session.Contents() 'loop through all sessions If (Mid(oSession, 1, 13) = "FroyaCartItem") Then 'if froya cart aSession = Session(oSession) 'save session to variable sSql = "INSERT INTO cartSaveItem " sSql = sSql & "(cartID, productID, productTitle, quantity, productPrice, productWeight, productDelivery, subTotal, specialField) " sSql = sSql & "VALUES (" sSql = sSql & "'" & Replace(iID,"'","''") & "'," sSql = sSql & "'" & Replace(aSession(0),"'","''") & "'," sSql = sSql & "'" & Replace(aSession(1),"'","''") & "'," sSql = sSql & "'" & Replace(aSession(2),"'","''") & "'," sSql = sSql & "'" & Replace(aSession(3),"'","''") & "'," sSql = sSql & "'" & Replace(aSession(4),"'","''") & "'," sSql = sSql & "'" & Replace(aSession(5),"'","''") & "'," sSql = sSql & "'" & Replace(aSession(6),"'","''") & "'," sSql = sSql & "'" & Replace(aSession(7),"'","''") & "'" sSql = sSql & ");" Call dbExecute(oConn, sSql) End If Next 'oSession 'save global cart sSql = "INSERT INTO cartSave " sSql = sSql & "(cartID, totalItems, totalPrice, totalWeight, totalDelivery, discountPrice, discountPercent, grandTotal) " sSql = sSql & "VALUES (" sSql = sSql & "'" & Replace(iID,"'","''") & "'," sSql = sSql & "'" & Replace(Session("FroyaCart")(0),"'","''") & "'," sSql = sSql & "'" & Replace(Session("FroyaCart")(1),"'","''") & "'," sSql = sSql & "'" & Replace(Session("FroyaCart")(2),"'","''") & "'," sSql = sSql & "'" & Replace(Session("FroyaCart")(3),"'","''") & "'," sSql = sSql & "'" & Replace(Session("FroyaCart")(4),"'","''") & "'" sSql = sSql & "'" & Replace(Session("FroyaCart")(5),"'","''") & "'" sSql = sSql & "'" & Replace(Session("FroyaCart")(6),"'","''") & "'" sSql = sSql & ");" Call dbExecute(oConn, sSql) End Function '################################################## Function cartLoadFromDatabase(oConn, iID) '//Process: load the cart from the database back into a session '//Return: true/false on success fail '//Param: oConn : database connection ' iID = ID of the cart to load '//Call: cartLoadFromdatabase() '//Version: 1 '//Created: 16/08/2006 CC '-VARS Dim oRSTemp, oRS2 '-PROCESS On Error Resume Next 'load main cart sSql = "SELECT DISTINCT * FROM cartSave WHERE cartID='" & Replace(iID,"'","''") & "';" Set oRSTemp = dbOpenRS(oConn, sSql) If (Not oRSTemp.EOF) Then oRS.MoveFirst Session("FroyaCart") = Array("" & oRSTemp("totalItems"), "" & oRSTemp("totalPrice"), "" & oRSTemp("totalWeight"), "" & oRSTemp("totalDelivery"), "" & oRSTemp("grandTotal")) 'get items sSql = "SELECT * FROM cartSaveItem WHERE cartID='" & Replace(iID,"'","''") & "';" Set oRS2 = dbOpenRS(oConn, sSql) If (oRS2.RecordCount <> 0) Then oRS2.MoveFirst Do While Not oRS2.EOF Session("FroyaCartItem[" & oRS2("productID") & "]") = Array("" & oRS2("productID"), "" & oRS2("productTitle"), "" & oRS2("quantity"), "" & oRS2("productPrice"), "" & oRS2("productWeight"), "" & oRS2("productDelivery"), "" & oRS2("subTotal"), "" & oRS2("specialField")) oRS2.MoveNext Loop End If 'delete old save sSql = "DELETE FROM cartSave WHERE cartID='" & Replace(iID,"'","''") & "';" Call dbExecute(oConn, sSql) sSql = "DELETE FROM cartSaveItem WHERE cartID='" & Replace(iID,"'","''") & "';" Call dbExecute(oConn, sSql) cartLoadFromDatabase = True Else cartLoadFromDatabase = False End If End Function %> <% '************************************************** '//Script: Catch and display errors and messages '//Copyright: 2004-2006 Froya Limited. All rights reserved. ' No part of this code maybe used or altered without prior permission of the owner '//Created: 19/07/2006 CC '//Modified: 29/09/2006 CC '************************************************** 'Function List ' errorTrap ' errorTrapOpject ' errorShow ' messageTrap ' messageShow '################################################## Function errorTrap(sError) '//Process: Trap an error '//Param: sError = the error message '//Return: N/A '//Call: erroTrap("string") '//Version: 1 '//Created: 19/07/06 CC '//Modified:28/09/06 CC '-PROCESS 'add error if there is one If (sError <> "") Then Session("systemErrors") = Session("systemErrors") & "|" & sError End If End Function '################################################## Function errorTrapObject(sObject) '//Process: Trap an errors object field '//Param: sObject = the error object '//Return: N/A '//Call: errorTrapObject("userame") '//Version: 1 '//Created: 28/09/06 CC '//Modified:28/09/06 CC '-PROCESS 'add object if there is one If (sObject <> "") Then Session("systemErrorObject") = Session("systemErrorObject") & "[" & sObject & "]" End If End Function '################################################## Function errorShow() '//Process: Show any errors '//Return: div with errors in it '//Call: Response.Write errorShow() '//Version: 1 '//Created: 19/07/06 CC '//Modified:28/09/06 CC '-VARS Dim sReturn : sReturn = "" '-PROCESS 'display the error if there are ones to display If (Session("systemErrors") <> "") Then sReturn = "
" & Replace(Mid(Session("systemErrors"),2), "|", "
") & "
" 'reset the session Session("systemErrors") = "" End If '-RETURN errorShow = sReturn End Function '################################################## Function errorShowObject(sObject) '//Process: tells whether the object named is trapped '//Param: sObject = the error object '//Return: True/False '//Call: errorShowObject("userame") '//Version: 1 '//Created: 28/09/06 CC '//Modified:29/09/06 CC '-PROCESS 'check if it's to be displayed If (InStr(Session("systemErrorObject"), "[" & sObject & "]") > 0) Then 'strip old error and return Session("systemErrorObject") = Replace(Session("systemErrorObject"), "[" & sObject & "]", "") errorShowObject = True Else errorShowObject = False End If End Function '################################################## Function messageTrap(sMessage) '//Process: Trap a message '//Param: sMessage = the message '//Return: N/A '//Call: erroMessage("string") '//Version: 1 '//Created: 28/09/06 CC '//Modified:29/09/06 CC '-PROCESS 'add error if there is one If (sMessage <> "") Then Session("systemMessages") = Session("systemMessages") & "|" & sMessage End If End Function '################################################## Function messageShow() '//Process: Show any messages '//Return: div with messages in it '//Call: Response.Write messageShow() '//Version: 1 '//Created: 28/09/06 CC '//Modified:29/09/06 CC '-VARS Dim sReturn : sReturn = "" '-PROCESS 'display the error if there are ones to display If (Session("systemMessages") <> "") Then sReturn = "
" & Replace(Mid(Session("systemMessages"),2), "|", "
") & "
" 'reset the session Session("systemMessages") = "" End If '-RETURN messageShow = sReturn End Function %> <% Server.ScriptTimeout = 5 'set low for development bDAllowed = True Dim db_sDatabasePath, render_sTemplatePath, iCategoryID, oConn, sDocument 'ONLINE PAYMENT GLOBALS Dim hsbcCpiUrl : hsbcCpiUrl = "https://www.cpi.hsbc.com/servlet" 'SDA GLOBAL Session("systemSiteThemePath") = "/theme/assets/" 'theme path Session("systemLoginScript") = "login.asp" 'security login path Session("systemCalendarPath") = "calendar.asp" 'calendar path '????? Session("systemFileSelectPath") = "fileSelect.asp" 'file select path '????? Dim security_bDomainLogin : security_bDomainLogin = True 'use automatic domain login Dim sda_sDefaultPage : sda_sDefaultPage = "sda.asp" Dim renderVar_title : renderVar_title = "" Dim renderVar_subMenu : renderVar_subMenu = "" Dim renderVar_pageNav : renderVar_pageNav = "" Dim renderVar_basketInfo : renderVar_basketInfo = "" Dim renderVar_content : renderVar_content = "" Dim renderVar_errors : renderVar_errors = "" Dim renderVar_messages : renderVar_messages = "" Dim renderVar_pageHeading : renderVar_Heading = "" Dim renderVar_pageSubHeading : renderVar_SubHeading = "" Dim renderVar_loginMenu : renderVar_loginMenu = wyebridgeLoginMenu() db_sDatabasePath = "/data-y34bgyzrwj/wy3br1dge.mdb" render_sTemplatePath = "theme/template.html" iPCategoryID = Request.QueryString("pcid") iSCategoryID = Request.QueryString("scid") cache_sFolderPath = "/cache" cache_iPeriod = 0 cache_sInterval = "d" bUseCache = cacheValid() '-setup global variables and objects 'If (bUseCache) Then ' sDocument = cacheLoad() 'Else ' Set oRSContent = contentGetRS() ' sRenderVar_menu = contentCreateMenu(false) ' sRenderVar_categoryMenu = hfdsGuideListPrimaryCategories(iPCategoryID) ' If (oRSContent.Eof) Then ' renderVar_title = "404 - Page Cannot Be Found" ' renderVar_body = "No content page found" ' Else ' renderVar_title = oRSContent("title") ' renderVar_body = oRSContent("description") ' End If 'End If '-CUSTOM FUNCTIONS '################################################## Function wyebridgeLoginMenu() '//Process: Check for a login and make appropriate menu '//Return: menu '//Version: 1 '//Created: 10/10/06 CC 'check for auto login and cookies If (Request.Cookies("PR4U_UID") <> "") Then Session("PR4U_UID") = Request.Cookies("PR4U_UID") Session("PR4U_PWD") = Request.Cookies("PR4U_PWD") Session("PR4U_NAME") = Request.Cookies("PR4U_NAME") Session("PR4U_EMAIL") = Request.Cookies("PR4U_EMAIL") End If If (Session("PR4U_UID") <> "" And Session("PR4U_PWD") <> "") Then wyebridgeLoginMenu = "your account | logout" Else wyebridgeLoginMenu = "register | login" End If End Function '################################################## Function wyebridgeCategories(oConn, iParent) 'recursive '//Process: List all categories and sub-categories for the sub menu '//Param: oConn = Database Connection ' iParent = Parent category a sub category belongs to '//Return: menu category list '//Call: response.write wyebridgeCategories(0) '//Version: 1 '//Created: 19/09/06 CC '-VARS Dim sReturn : sReturn = "" Dim sSql : sSql = "" Dim oRSTemp '-PROCESS sSql = "SELECT * FROM [category] WHERE (parentID=" & iParent & ") AND (status=1) ORDER BY [title];" Set oRSTemp = dbOpenRS(oConn, sSql) If (Not oRSTemp.EOF) Then Do While Not oRSTemp.EOF 'check for primary category If (oRSTemp("parentID") = 0) Then sReturn = sReturn & "" & vbCrLf Else sReturn = sReturn & vbTab & "
  • " & oRSTemp("title") & "
    • " & vbCrLf End If sReturn = sReturn & "" oRSTemp.MoveNext Loop End If Set oRSTemp = Nothing '-RETURN wyebridgeCategories = sReturn End Function '################################################## Function wyebridgeShopCategories(oConn) '//Process: List all main shop categories '//Param: oConn = Database Connection '//Return: table of categories '//Call: response.write wyebridgeShopCategories(oConn) '//Version: 1 '//Created: 22/09/06 CC '-VARS Dim sReturn : sReturn = "" Dim sSql : sSql = "" Dim oRSTemp '-PROCESS sSql = "SELECT * FROM [category] WHERE (parentID=0) AND (status=1) ORDER BY [title];" Set oRSTemp = dbOpenRS(oConn, sSql) If (Not oRSTemp.EOF) Then 'display categories table sReturn = sReturn & "" & vbCrLf Do While Not oRSTemp.EOF 'check for primary category sReturn = sReturn & vbTab & "" & vbCrLf If (oRSTemp("image") <> "") Then sReturn = sReturn & vbTab & vbTab & "" & vbCrLf Else sReturn = sReturn & vbTab & vbTab & "" & vbCrLf End If sReturn = sReturn & vbTab & vbTab & "" & vbCrLf sReturn = sReturn & vbTab & "" & vbCrLf oRSTemp.MoveNext Loop sReturn = sReturn & "

    " & oRSTemp("title") & "


    " 'get the description and check length and add dots if needed sDescription = Mid(oRSTemp("description"),1,150) If (Len(oRSTemp("description")) > 150) Then sDescription = sDescription & "..." sReturn = sReturn & sDescription & vbCrLf '-PROCESS ' sSql = "SELECT *, (SELECT COUNT(productID) FROM [product] WHERE (status=1) AND ( (categoryID1=c.categoryID) OR (categoryID2=c.categoryID) OR (categoryID3=c.categoryID))) AS ProductCount FROM [category] c WHERE (parentID=" & oRSTemp("categoryID") & ") AND (status=1) ORDER BY [title];" sSql = "SELECT *, (SELECT COUNT(productID) FROM [product] WHERE ((categoryID1=c.categoryID) OR (categoryID2=c.categoryID) OR (categoryID3=c.categoryID))) AS ProductCount FROM [category] c WHERE (parentID=" & oRSTemp("categoryID") & ") AND ((status=1) OR (status=3)) ORDER BY [title];" Set oRSTemp2 = dbOpenRS(oConn, sSql) If (Not oRSTemp2.EOF) Then sReturn = sReturn & "
      " & vbCrLf Do While Not oRSTemp2.EOF sReturn = sReturn & vbTab & "
    • " & oRSTemp2("title") & " (" & oRSTemp2("ProductCount") & ")
      • " & vbCrLf oRSTemp2.MoveNext Loop sReturn = sReturn & "
    " & vbCrLf End If sReturn = sReturn & "
    " & vbCrLf End If Set oRSTemp = Nothing '-RETURN wyebridgeShopCategories = sReturn End Function '################################################## Function wyebridgeProducts(oConn, iCategory, iPage, sSearch) '//Process: List all products in a given category '//Param: oConn : Database Connection ' iCategory : category ID to display products from ' iPage : page number we are on ' sSearch : search criteria '//Return: product table '//Call: response.write wyebridgeProducts(oConn, 2) '//Version: 1 '//Created: 19/09/06 CC '-VARS Dim sReturn : sReturn = "" Dim sSql : sSql = "" Dim oRSTemp Dim sDescription : sDescription = "" 'temp description holder Dim iPrice : iPrice = "" 'temp price line holder Dim sForm : sForm = "" 'add to basket form Dim aSearch 'array of search criteria Dim bClose : bClose = True 'to check for close table cell Dim sImage : sImage = "" 'image or no-image image Dim iParent : iParent = 0 'default parent to 0, primary '-PROCESS ' On Error Resume Next 'Category Info 'category information if a category selected If (IsNumeric(iCategory) And iCategory <> "") Then sSql = "SELECT * FROM [category] WHERE (categoryID=" & iCategory & ") AND (status=1);" 'open recordset for products Set oRSTemp = dbOpenRS(oConn, sSql) If (Not oRSTemp.EOF) Then 'check primary/secondary If (oRSTemp("parentID") = 0) Then 'Primary Category sSql = "SELECT pageContent FROM [page] WHERE pageID=4;" Set oRSTemp2 = dbOpenRS(oConn, sSql) If (oRSTemp2.RecordCount <> 0) Then sReturn = sReturn & "

    " & oRSTemp2("pageContent") & "

    " End If 'display categories table sReturn = sReturn & "" & vbCrLf sReturn = sReturn & vbTab & "" & vbCrLf If (oRSTemp("image") <> "") Then sReturn = sReturn & vbTab & vbTab & "" & vbCrLf Else sReturn = sReturn & vbTab & vbTab & "" & vbCrLf End If sReturn = sReturn & vbTab & vbTab & "" & vbCrLf sReturn = sReturn & vbTab & "" & vbCrLf sReturn = sReturn & "

    " & oRSTemp("title") & "

    " sReturn = sReturn & oRSTemp("description") & vbCrLf '-PROCESS sSql = "SELECT *, (SELECT COUNT(productID) FROM [product] WHERE ((status=1) OR (status=3)) AND ( (categoryID1=c.categoryID) OR (categoryID2=c.categoryID) OR (categoryID3=c.categoryID))) AS ProductCount FROM [category] c WHERE (parentID=" & oRSTemp("categoryID") & ") AND (status=1) ORDER BY [title];" Set oRSTemp2 = dbOpenRS(oConn, sSql) If (Not oRSTemp2.EOF) Then sReturn = sReturn & "

    categories

    " & vbCrLf sReturn = sReturn & "
      " & vbCrLf Do While Not oRSTemp2.EOF sDescription = Mid(oRSTemp2("description"),1,150) If (Len(oRSTemp2("description")) > 150) Then sDescription = sDescription & "..." sReturn = sReturn & vbTab & "
    • " & oRSTemp2("title") & " (" & oRSTemp2("ProductCount") & ")" & vbCrLf sReturn = sReturn & vbTab & "
      " & sDescription & "

      " & vbCrLf sReturn = sReturn & vbTab & "
      • " & vbCrLf oRSTemp2.MoveNext Loop sReturn = sReturn & "
    " & vbCrLf End If sReturn = sReturn & "
    " & vbCrLf Else '################################################## 'Products sSql = "SELECT pageContent FROM [page] WHERE pageID=5;" Set oRSTemp2 = dbOpenRS(oConn, sSql) If (oRSTemp2.RecordCount <> 0) Then sReturn = sReturn & "

    " & oRSTemp2("pageContent") & "

    " End If 'display description, if first page only If (oRSTemp("description") <> "" And (iPage=1 Or IsEmpty(iPage))) Then sReturn = sReturn & "

    " & oRSTemp("description") & "


     

    " & vbCrLf End If 'make sql and check for search If (IsNull(sSearch) Or IsEmpty(sSearch) Or sSearch="") Then 'normal sSql = "SELECT * FROM [product] WHERE (" sSql = sSql & "(categoryID1=" & iCategory & ") OR " sSql = sSql & "(categoryID2=" & iCategory & ") OR " sSql = sSql & "(categoryID3=" & iCategory & ")) AND " sSql = sSql & "((status=1) OR (status=3)) " sSql = sSql & "ORDER BY [title];" Else 'search sSql = "SELECT * FROM [product] WHERE (" aSearch = Split(Replace(sSearch,"'","''"), " ") For Each item in aSearch sSql = sSql & "(title LIKE '%" & item & "%') OR " sSql = sSql & "(description LIKE '%" & item & "%') OR " Next 'search array sSql = Mid(sSql, 1, InStrRev(sSql, "OR") - 1) & ") AND " sSql = sSql & "((status=1) OR (status=3)) " sSql = sSql & "ORDER BY [title];" End If 'open recordset for products Set oRSTemp = dbOpenRS(oConn, sSql) If (Not oRSTemp.EOF) Then 'set pages If (IsEmpty(iPage) Or IsNull(iPage) Or (Not IsNumeric(iPage))) Then iPage = 1 'default page oRSTemp.PageSize = iProductsPerPage oRSTemp.AbsolutePage = iPage sReturn = sReturn & "" & vbCrLf ' Do While Not oRSTemp.EOF For iRecord = 1 To (oRSTemp.PageSize) If (Not oRSTemp.EOF) Then 'get the description and check length and add dots if needed sDescription = Mid(oRSTemp("description"),1,150) If (Len(oRSTemp("description")) > 150) Then sDescription = sDescription & "..." 'get the price or discount and display the line If (IsNumeric(oRSTemp("discountPriceIncVat")) And (oRSTemp("discountPriceIncVat") > 0)) Then iPrice = FormatNumber(oRSTemp("discountPriceIncVat"),2,,,0) ElseIf (IsNumeric(oRSTemp("priceIncVat"))) Then iPrice = FormatNumber(oRSTemp("priceIncVat"),2,,,0) Else iPrice = 0 End If 'build the form 'don't show price or buy button if price is 0 (zero) If (iPrice <> 0) Then sForm = "
    " sForm = sForm & "" sForm = sForm & "" 'check stock status If (oRSTemp("status") = 3) Then sForm = sForm & vbTab & vbTab & vbTab & "Out of Stock
    " & vbCrLf End If sForm = sForm & "£" & iPrice & "" sForm = sForm & "" sForm = sForm & "" & vbCrLf End If 'check for image defined If (oRSTemp("imageSmall") <> "") Then sImage = oRSTemp("imageSmall") Else sImage = "assets/_no-image.gif" End If 'check for left or right product column If ((oRSTemp.AbsolutePosition mod 2) = 1) Then 'left column sReturn = sReturn & vbTab & "" & vbCrLf sReturn = sReturn & vbTab & vbTab & "" & vbCrLf sReturn = sReturn & vbTab & vbTab & "" & vbCrLf 'add form to next column sTemp = sTemp & vbTab & "" & vbCrLf bClose = True Else 'right column sReturn = sReturn & vbTab & vbTab & "" & vbCrLf sReturn = sReturn & vbTab & vbTab & "" & vbCrLf sReturn = sReturn & vbTab & "" & vbCrLf 'add form to next column and apply it sTemp = sTemp & "" & vbCrLf sReturn = sReturn & sTemp sTemp = "" bClose = False End If oRSTemp.MoveNext End If Next 'iRecord ' Loop 'close table correctly for odd number of products and put a blank cell in If (bClose) Then sReturn = sReturn & vbTab & vbTab & "" & vbCrLf sReturn = sReturn & vbTab & vbTab & "" & vbCrLf sReturn = sReturn & vbTab & "" & vbCrLf sTemp = sTemp & "" & vbCrLf sReturn = sReturn & sTemp sTemp = "" End If sReturn = sReturn & vbTab & "
    " & vbCrLf sReturn = sReturn & vbTab & vbTab & vbTab & "

    " & oRSTemp("title") & "

    " & vbCrLf sReturn = sReturn & vbTab & vbTab & vbTab & sDescription & vbCrLf sReturn = sReturn & vbTab & vbTab & "
    " & vbCrLf & sForm & vbCrLf & "" & vbCrLf sReturn = sReturn & vbTab & vbTab & vbTab & "

    " & oRSTemp("title") & "

    " & vbCrLf sReturn = sReturn & vbTab & vbTab & vbTab & sDescription & vbCrLf sReturn = sReturn & vbTab & vbTab & "
    " & vbTab & sForm & vbCrLf & "
      
     
    " & vbCrLf Else 'no products found sReturn = sReturn & "

    Sorry, but there are no products in this category

     

     

    " End If 'oRS.EOF End If 'primary category check End If 'category exists ElseIf (sSearch <> "") Then 'search 'make sql and check for search sSql = "SELECT * FROM [product] WHERE (" aSearch = Split(Replace(sSearch,"'","''"), " ") For Each item in aSearch sSql = sSql & "(title LIKE '%" & item & "%') OR " sSql = sSql & "(description LIKE '%" & item & "%') OR " Next 'search array sSql = Mid(sSql, 1, InStrRev(sSql, "OR") - 1) & ") AND " sSql = sSql & "((status=1) OR (status=3)) " sSql = sSql & "ORDER BY [title];" 'open recordset for products Set oRSTemp = dbOpenRS(oConn, sSql) If (Not oRSTemp.EOF) Then 'set pages If (IsEmpty(iPage) Or IsNull(iPage) Or (Not IsNumeric(iPage))) Then iPage = 1 'default page oRSTemp.PageSize = iProductsPerPage oRSTemp.AbsolutePage = iPage sReturn = sReturn & "" & vbCrLf ' Do While Not oRSTemp.EOF For iRecord = 1 To (oRSTemp.PageSize) If (Not oRSTemp.EOF) Then 'get the description and check length and add dots if needed sDescription = Mid(oRSTemp("description"),1,150) If (Len(oRSTemp("description")) > 150) Then sDescription = sDescription & "..." 'get the price or discount and display the line If (IsNumeric(oRSTemp("discountPriceIncVat")) And (oRSTemp("discountPriceIncVat") > 0)) Then iPrice = FormatNumber(oRSTemp("discountPriceIncVat"),2,,,0) ElseIf (IsNumeric(oRSTemp("priceIncVat"))) Then iPrice = FormatNumber(oRSTemp("priceIncVat"),2,,,0) Else iPrice = 0 End If 'build the form 'don't show price or buy button if price is 0 (zero) If (iPrice <> 0) Then ' sForm = "" sForm = "
    " sForm = sForm & "" sForm = sForm & "" sForm = sForm & "£" & iPrice & "" sForm = sForm & "" sForm = sForm & "" & vbCrLf End If 'check for image defined If (oRSTemp("imageSmall") <> "") Then sImage = oRSTemp("imageSmall") Else sImage = "assets/_no-image.gif" End If 'check for left or right product column If ((oRSTemp.AbsolutePosition mod 2) = 1) Then 'left column sReturn = sReturn & vbTab & "" & vbCrLf sReturn = sReturn & vbTab & vbTab & "" & vbCrLf sReturn = sReturn & vbTab & vbTab & "" & vbCrLf 'add form to next column sTemp = sTemp & vbTab & "" & vbCrLf bClose = True Else 'right column sReturn = sReturn & vbTab & vbTab & "" & vbCrLf sReturn = sReturn & vbTab & vbTab & "" & vbCrLf sReturn = sReturn & vbTab & "" & vbCrLf 'add form to next column and apply it sTemp = sTemp & "" & vbCrLf sReturn = sReturn & sTemp sTemp = "" bClose = False End If oRSTemp.MoveNext End If Next 'iRecord ' Loop 'close table correctly for odd number of products and put a blank cell in If (bClose) Then sReturn = sReturn & vbTab & vbTab & "" & vbCrLf sReturn = sReturn & vbTab & vbTab & "" & vbCrLf sReturn = sReturn & vbTab & "" & vbCrLf sTemp = sTemp & "" & vbCrLf sReturn = sReturn & sTemp sTemp = "" End If sReturn = sReturn & vbTab & "
    " & vbCrLf sReturn = sReturn & vbTab & vbTab & vbTab & "

    " & oRSTemp("title") & "

    " & vbCrLf sReturn = sReturn & vbTab & vbTab & vbTab & sDescription & vbCrLf sReturn = sReturn & vbTab & vbTab & "
    " & vbCrLf & sForm & vbCrLf & "" & vbCrLf sReturn = sReturn & vbTab & vbTab & vbTab & "

    " & oRSTemp("title") & "

    " & vbCrLf sReturn = sReturn & vbTab & vbTab & vbTab & sDescription & vbCrLf sReturn = sReturn & vbTab & vbTab & "
    " & vbTab & sForm & vbCrLf & "
      
     
    " & vbCrLf Else 'no products found sReturn = sReturn & "

    Sorry, but there are no products in this category

     

     

    " End If 'oRS.EOF End If 'numeric category / search Set oRSTemp = Nothing '-RETURN wyebridgeProducts = sReturn End Function '################################################## Function wyebridgeDetail(oConn, iProduct) '//Process: List a full product detail '//Param: oConn : Database Connection ' iProduct : the ID of the product '//Return: product table '//Call: response.write wyebridgeDetail(oConn, 2, 4) '//Version: 1 '//Created: 20/09/06 CC '-VARS Dim sReturn : sReturn = "" Dim sSql : sSql = "" Dim oRSTemp Dim sDescription : sDescription = "" 'temp description holder Dim iPrice : iPrice = "" 'temp price line holder Dim sForm : sForm = "" 'add to basket form Dim sImage: sImage = "" 'image or no-image image '-PROCESS ' On Error Resume Next sSql = "SELECT * FROM [product] WHERE " sSql = sSql & "(productID=" & iProduct & ") AND " sSql = sSql & "((status=1) OR (status=3));" Set oRSTemp = dbOpenRS(oConn, sSql) If (Not oRSTemp.EOF) Then sReturn = sReturn & "" & vbCrLf 'get the price or discount and display the line If (IsNumeric(oRSTemp("discountPriceIncVat")) And (oRSTemp("discountPriceIncVat") > 0)) Then iPrice = FormatNumber(oRSTemp("discountPriceIncVat"),2,,,0) ElseIf (IsNumeric(oRSTemp("priceIncVat"))) Then iPrice = FormatNumber(oRSTemp("priceIncVat"),2,,,0) Else iPrice = 0 End If 'check for image defined If (oRSTemp("imageLarge") <> "") Then sImage = oRSTemp("imageLarge") Else sImage = "assets/_no-image-lg.gif" End If 'left column sReturn = sReturn & vbTab & "" & vbCrLf sReturn = sReturn & vbTab & vbTab & "" & vbCrLf sReturn = sReturn & vbTab & vbTab & "" & vbCrLf sReturn = sReturn & vbTab & "
    " & vbCrLf sReturn = sReturn & vbTab & vbTab & vbTab & "

    " & oRSTemp("title") & "

    " & vbCrLf sReturn = sReturn & vbTab & vbTab & vbTab & oRSTemp("description") & "

    " & vbCrLf 'supplier ' On Error Resume Next ' sSql = "SELECT * FROM [supplier] WHERE (supplierID=" & oRSTemp("supplierID") & ") AND (title<>'');" ' Set oRSSupplier = dbOpenRS(oConn, sSql) ' If (oRSSupplier.RecordCount <> 0) Then ' If (oRSSupplier("image") <> "") Then ' sSupplierTitle = "
    " ' Else ' sSupplierTitle = oRSSupplier("title") ' End If ' If (oRSSupplier("website") <> "") Then ' sReturn = sReturn & vbTab & vbTab & vbTab & "Supplier: " & sSupplierTitle & "
    " & vbCrLf ' Else ' sReturn = sReturn & vbTab & vbTab & vbTab & "Supplier: " & sSupplierTitle & "
    " & vbCrLf ' End If ' End If sReturn = sReturn & vbTab & vbTab & vbTab & "

     

    " & vbCrLf 'build the form 'don't show price or buy button if price is 0 (zero) If (iPrice <> 0) Then sReturn = sReturn & "
    " sReturn = sReturn & "" sReturn = sReturn & "" sReturn = sReturn & "£" & iPrice & "" sReturn = sReturn & "" sReturn = sReturn & "

    " & vbCrLf End If sReturn = sReturn & vbTab & vbTab & vbTab & "

     

    " & vbCrLf sReturn = sReturn & vbTab & vbTab & "
    " & vbCrLf 'related products sReturn = sReturn & wyebridgeRelatedProducts(oConn, iProduct) Else 'no products found sReturn = sReturn & "

    Sorry, but the selected product could not be found

     

     

    " End If 'oRS.EOF Set oRSTemp = Nothing '-RETURN wyebridgeDetail = sReturn End Function '################################################## Function wyebridgeRelatedProducts(oConn, iProduct) '//Process: List a products other related products '//Param: oConn : Database Connection ' iProduct : the ID of the product '//Return: product table '//Call: response.write wyebridgeDetail(oConn, 2, 4) '//Version: 1 '//Created: 20/09/06 CC '-VARS Dim sReturn : sReturn = "" Dim sSql : sSql = "" Dim oRSTemp Dim sDescription : sDescription = "" 'temp description holder Dim iPrice : iPrice = "" 'temp price line holder Dim sForm : sForm = "" 'add to basket form '-PROCESS ' On Error Resume Next sSql = "SELECT TOP 3 productID, title, imageSmall " sSql = sSql & "FROM [product] " sSql = sSql & "WHERE " sSql = sSql & "(productID IN (" sSql = sSql & " SELECT DISTINCT productID FROM [product] WHERE " sSql = sSql & " (relatedID1=" & iProduct & ") OR " sSql = sSql & " (relatedID2=" & iProduct & ") OR " sSql = sSql & " (relatedID3=" & iProduct & ")" sSql = sSql & ")) AND " sSql = sSql & "(imageSmall<>'') AND " sSql = sSql & "((status=1) OR (status=3));" Set oRSTemp = dbOpenRS(oConn, sSql) If (Not oRSTemp.EOF) Then sReturn = sReturn & "

    Related Products

    " & vbCrLf sReturn = sReturn & "

    If you like the product above, you may wish to look at these splendid items also.

    " & vbCrLf sReturn = sReturn & "" & vbCrLf sReturn = sReturn & vbTab & "" & vbCrLf Do While Not oRSTemp.EOF sReturn = sReturn & vbTab & vbTab & "" & vbCrLf oRSTemp.MoveNext Loop sReturn = sReturn & vbTab & "" & vbCrLf sReturn = sReturn & vbTab & "

    " & oRSTemp("title") & "
    " & vbCrLf End If 'oRS.EOF Set oRSTemp = Nothing '-RETURN wyebridgeRelatedProducts = sReturn End Function '################################################## Function wyebridgePageNavigation(oConn, iCategory, iPage, sSearch) '//Process: List all categories and sub-categories for the sub menu '//Param: oConn = Database Connection ' iCategory : current category ID ' iPage : current page number ' sSearch : search criteria '//Return: page navigation menu '//Call: response.write wyebridgePageNavigation(oConn, 2, 4) '//Version: 1 '//Created: 21/09/06 CC '-VARS Dim sReturn : sReturn = "" Dim oRSTemp Dim aSearch 'array of search criteria Dim sScript : sScript = "" Dim sExtra : sExtra = "" '-PROCESS ' On Error Resume Next 'make sql and check for search If (IsNull(sSearch) Or IsEmpty(sSearch) Or sSearch="") Then 'normal sSql = "SELECT * FROM [product] WHERE " sSql = sSql & "(categoryID1=" & iCategory & ") OR " sSql = sSql & "(categoryID2=" & iCategory & ") OR " sSql = sSql & "(categoryID3=" & iCategory & ") AND " sSql = sSql & "((status=1) OR (status=3)) " sSql = sSql & "ORDER BY [title];" sExtra = "&cid=" & Request.QueryString("cid") Else 'search sSql = "SELECT * FROM [product] WHERE " aSearch = Split(Replace(sSearch,"'","''"), " ") For Each item in aSearch sSql = sSql & "(title LIKE '%" & item & "%') OR " sSql = sSql & "(description LIKE '%" & item & "%') OR " Next 'search array sSql = Mid(sSql, 1, InStrRev(sSql, "OR") - 1) & "AND " sSql = sSql & "((status=1) OR (status=3)) " sSql = sSql & "ORDER BY [title];" sExtra = "&search=" & sSearch End If Set oRSTemp = dbOpenRS(oConn, sSql) If (Not oRSTemp.EOF) Then 'get script to return to sScript = Mid(Request.ServerVariables("SCRIPT_NAME"),InStrRev(Request.ServerVariables("SCRIPT_NAME"),"/") + 1) 'set page default if needed If (IsEmpty(iPage) Or IsNull(iPage) Or (Not IsNumeric(iPage))) Then iPage = 1 'default page 'prev page link If (Int(iPage) > 1) Then sReturn = sReturn & "prev" Else sReturn = sReturn & "prev" End If sReturn = sReturn & "  " For iCount = 1 To Round((oRSTemp.RecordCount / iProductsPerPage) + 0.5) If (Int(iCount) = Int(iPage)) Then sReturn = sReturn & "" & iCount & "" Else sReturn = sReturn & "" & iCount & "" End If sReturn = sReturn & " " Next 'iCount sReturn = sReturn & " " 'next page link If (Int(iPage) < (Int(iCount)-1)) Then sReturn = sReturn & "next" Else sReturn = sReturn & "next" End If End If 'oRS.EOF Set oRSTemp = Nothing '-RETURN wyebridgePageNavigation = sReturn End Function '################################################## Function wyebridgeDisplayPromotion(oConn, iPage) '//Process: Display an active promotion '//Params: oConn = database connection ' iPage = ID of the page to display a promotion for '//Return: promo code or default image '//Version: 1 '//Created: 10/11/06 '-VARS Dim oRSTemp Dim sReturn : sReturn = "" '-PROCESS sSql = "SELECT TOP 1 * FROM [promo] WHERE (image <> '') AND (pageID=" & iPage & ") AND (active=1);" Set oRSTemp = dbOpenRS(oConn, sSql) If (Not oRSTemp.EOF) Then If (oRSTemp.RecordCount <> 0) Then sReturn = "" End If End If Set oRSTemp = Nothing '-RETURN wyebridgeDisplayPromotion = sReturn End Function '################################################## Function wyebridgeInitiatePromotion(oConn, sCode) '//Process: Initiate a promotion in the cart '//Params: oConn = database connection ' sCode = promotion code '//Return: address to go to? '//Version: 1 '//Created: 10/11/06 '-VARS Dim oRSTemp Dim sReturn : sReturn = "http://www.presentsr4u.com"'Mid(Request.ServerVariables("HTTP_REFERER"), InStrRev(Request.ServerVariables("HTTP_REFERER"),"/") + 1) '-PROCESS sSql = "SELECT TOP 1 * FROM [promo] WHERE (promotionCode='" & Replace(sCode, "'", "''") & "') AND (active=1);" Set oRSTemp = dbOpenRS(oConn, sSql) If (Not oRSTemp.EOF) Then If (oRSTemp.RecordCount <> 0) Then 'apply discount cartSetDiscountPercent(oRSTemp("discountPercent")) 'check for redirect If (oRSTemp("url") <> "") Then sReturn = oRSTemp("url") End If 'send message Call messageTrap("A discount of " & oRSTemp("discountPercent") & "% will be applied to your order, thank you.") End If End If Set oRSTemp = Nothing '-RETURN wyebridgeInitiatePromotion = sReturn End Function '################################################## Function wyebridgeClearOrder() '//Process: Clear all sessions associated with an order '//Version: 1 '//Created: 26/10/06 CC Session("deliveryName") = "" Session("deliveryFirstName") = "" Session("deliveryLastName") = "" Session("deliveryCompany") = "" Session("deliveryAddress") = "" Session("deliveryAddress2") = "" Session("deliveryCity") = "" Session("deliveryCounty") = "" Session("deliveryPostcode") = "" Session("deliveryPhone") = "" For iSessionCount = 1 To 5 For Each oSession In Session.Contents() 'loop through all sessions If (Mid(oSession, 1, 13) = "FroyaCartItem") Then 'if froya cart Session.Contents.Remove(oSession) ElseIf (Mid(oSession, 1, 9) = "FroyaCart") Then 'if froya cart Session.Contents.Remove(oSession) End If Next Next Session("FroyaCart") = "" For Each oSession In Session.Contents() If (Mid(oSession, 1, 7) = "payment") Then 'if froya payment session Session.Contents.Remove(oSession) End If Next Session.Abandon() End Function %> <% On Error Resume Next 'open default connection for all pages Set oConn = dbOpenConn(Server.MapPath(db_sDatabasePath)) 'Check for valid product If (Not IsNumeric(Request.QueryString("pid"))) Then Response.Redirect "default.asp" End If sSql = "SELECT title FROM [category] WHERE (categoryID=(SELECT parentID FROM [category] WHERE categoryID=(SELECT categoryID1 FROM [product] WHERE productID=" & Request.QueryString("pid") & ")));" Dim sPrimaryCategory : sPrimaryCategory = dbGetValue(oConn, sSql) sSql = "SELECT title FROM [category] WHERE (categoryID=(SELECT categoryID1 FROM [product] WHERE productID=" & Request.QueryString("pid") & "));" Dim sSubCategory : sSubCategory = dbGetValue(oConn, sSql) sSql = "SELECT title FROM [product] WHERE (productID=" & Request.QueryString("pid") & ");" Dim sProductTitle : sProductTitle = dbGetValue(oConn, sSql) 'PAGE TITLE renderVar_title = sPrimaryCategory & " > " & sSubCategory & " > " & sProductTitle & " @ presentsR4U.com" 'PAGE DESCRIPTION renderVar_description = dbGetValue(oConn, "SELECT description FROM [product] WHERE (productID=" & Request.QueryString("pid") & ");") 'BANNER renderVar_banner = wyebridgeDisplayPromotion(oConn, 6) 'SUB MENU renderVar_subMenu = wyebridgeCategories(oConn, 0) 'PAGE NAVIGATION renderVar_pageNav = "" 'BASKET INFO On Error Resume Next renderVar_basketInfo = "view basket | items " & Session("FroyaCart")(0) & " | £" & FormatNumber(Session("FroyaCart")(6),2,,,0) & "" On Error GoTo 0 'PAGE HEADING renderVar_pageHeading = sPrimaryCategory 'PAGE SUB HEADING renderVar_pageSubHeading = sSubCategory 'CONTENT renderVar_content = wyebridgeDetail(oConn, Request.QueryString("pid")) If (Not bUseCache) Then sDocument = renderTemplate("theme/productTemplate.html") Call cacheSave(sDocument) sDocument = renderContent(sDocument) End If sDocument = renderContent(sDocument) Response.Write(sDocument) %>