File: D:/web/coventrydemolition/2023-11-28/prev/dbfunctions.asp
<!--#include virtual="common/asp/rijndael.asp"-->
<!--#include virtual="common/asp/jsonObject.class.asp"-->
<%
' ===============
' dbfunctions.asp
' ===============
' Version 2.00 (01/08/22)
' ============
' HISTORY
' ============
' (SS,27/06/05) Add check for Null in Function CleanSQLStr and setting it to "" to avoid invalid use of null errors '
' (SS,18/09/06) Added Sub OpenDatabaseCommon
' (SS,17/10/06) Added IsDatabaseOpen
' (SS,18/05/07) Added Function NZD
' Added Function GetQueryRecordCount
' (SS,21/05/07) Added Function NZL
' Added Sub SetDebugLevel and gnDebugLevel
' Added 'And gnDebugLevel > 1' to GetQueryValue and GetQueryValue2
' to ensure GetQueryValue debugs only shown when DebugLevel is > 1
' default debug level is 1 (use SetDebugLevel(2) to see GetQueryValue logs)
' (SS,22/05/07) Added new function ENKN, slight mods to NZ and NB
' (SS,26/05/07) Added new function StrToBool
' Added ShowOpenDatabaseCount and global gnOpenDatabaseCount, gnCloseDatabaseCount to show count of database opens and closes
' Changes to OpenDatabaseCommon
' Added CloseDatabaseCommon, OpenQueryCommon, CloseQueryCommon to help with single OpenDatabase and CloseDatabase in apputils
' Added IncOpenQueryCount, IncCloseQueryCount, IncExecQueryCount (and gnOpenQueryCount, gnCloseQueryCount, gnExecQueryCount)
' (SS,27/05/07) Added Function FieldExistsInTable
' (SS,28/05/07) Modified Function Round2dp to return a Double instead of String
' Added Function FunctionExists
' (SS,30/05/07) Added ToNamedHTML
' (SS,01/06/07) Renamed IntAsBool to IntToBool, BoolAsInt to BoolToInt
' Added FieldsExistInQuery, FieldExists
' (SS,04/06/07) Added Function TrimAll
' (SS,14/06/07) Renamed GetAppSetting to GetSetting and SetAppSetting to SetSetting, remove TypeID and EntryID from these functions
' (SS,05/07/07) Added HTMLEncode function
' (SS,14/09/07) Added ExecuteQueryCommon
' (SS,14/11/07) Added Sub AddSetting
' (SS,21/10/08) Added Function IsCharAlpha, Function IsCharNumeric, Function StripSpaces and Function SplitPostcode
' (SS,12/11/08) Added Function Format2dpnc
' (SS,17/11/08) Added functions SingleQuotedJavascriptString and DoubleQuotedJavascriptString
' (SS,17/04/09) Added Functions IsWorkingDay, NextWorkingDay, GetDeliveryDateCombo, ConvertUKToMySQLDate
' (SS,22/04/09) Change to Function HTMLEncode to prevent "Type Mismatch" error
' (SS,08/05/09) Change to Function ConvertUKToMySQLDate to return date without "-" and Null as string
' (SS,28/05/09) Added Function IsURL
' (SS,29/05/09) Moved Function ReplaceNewLinesWithBR here from apputils.asp
' (SS,04/06/09) Added Function RemoveNewLines
' (SS,05/06/09) Added Function URLEncode
' (SS,12/06/09) Added Function RandomInteger
' (SS,23/06/09) Added functions TrimChar and TrimChars, changed TrimAll to call TrimChars
' Added Function CleanPageName (from siteutil.asp)
' (SS,14/07/09) Changed to CleanSQLStr to handle ASCII controls codes like linefeed & carriage return
' (SS,16/07/09) Changes to allow this dbfunctions.asp to be used with csl/book app
' Newer version of GetLookupCombo with extra AValueField
' Improved version of Function ConvertNewlinesToHTML
' Added Function ConvertNewlinesForJavascript
' Function GetSetting renamed to Function GetSettingFromField with new AValueField
' New Function GetSetting nows calls GetSettingFromField
' Also added Function GetSettingMemo to get memo value
' Also copied Function FileExists, Sub DeleteFile, Sub CopyFile
' Added extra set of query functions and subs OpenQuery3, CloseQuery3, EndOfQuery3, NextQueryRecord3, GetQueryValue3, also oRS3 global
' (SS,21/07/09) Underscore bug fix to CleanSQLStr and added new CleanSQLStrForLike (not tested)
' Bugfix to Function GetSettingFromField
' (SS,27/07/09) Added Function GetQueryField alias to Function GetQueryValue, GetQueryField2 alias to GetQueryValue2 and GetQueryField3 alias to GetQueryValue3
' (SS,29/07/09) Change to Function IntToBool to treat null as False also
' (SS,22/09/09) Added Function URLDecode
' (SS,28/10/09) Change to OpenQueryCommon and CloseQueryCommon to use oRScommon, added new routines EndOfQueryCommon, NextQueryRecordCommon and GetQueryValueCommon
' To prevent clash of recordset with normal routines if common database is required while main database is open.
' (SS,27/05/10) Improved debugging features, now logs to file, adding timings to help detect speed of queries
' (SS,23/06/10) Change to Sub DebugLog to log only when debugging is enabled
' Added functions IsMixedCase, ProperCase, Proper, CorrectPostcode, CorrectPostcodeForUK
' used to correct the case for user entered addresses, because many users don't correctly capitalise
' (SS,25/06/10) Added Sub LogErrorToFile for logging directly to a file for current site
' (SS,19/07/10) Added Function SEOFriendlyStr
' (SS,20/07/10) Added Min and Max functions
' (SS,17/05/11) Added HTMLEncodeQuotesAndPounds and ConvertNewlinesEtcToHTML
' Also change to ConvertNewlinesToHTML to use <br /> instead of <br>
' (SS,19/05/11) Added CurrencyCharToHTML
' (SS,23/05/11) Changed to renamed HTMLEncodeQuotesAndPounds to HTMLEncodeSpecialChars
' also added chr 149 and 150 to HTMLEncodeSpecialChars
' Also replaced <br> with <br /> in Function ReplaceNewLinesWithBR
' (SS,24/05/11) Changes to Function HTMLEncodeSpecialChars to handle all chars 128 and above
' (SS,25/05/11) Minor change to SplitPostcode to return inward when there is no suffix
' (SS,03/06/11) Added Const BR and replaced all "<br />" with BR
' (SS,20/06/11) Added Sub SetSelectClass, Function GetSelectClass and gsSelectClass, to allow the class for combo boxes to the set/overridden
' Replaced all class=""form"" with GetSelectClass
' (SS,22/06/11) Added GetUniqueCount, to return a unique number, incremented by one each time it's called
' (SS,30/06/11) Added new functions GetSQLValue, GetSQLValueAsString
' (SS,01/07/11) Added Sub WebDebugLog which logs when debuglevel is 3 or above
' Added Function GetSQLLastInsertID() and GetSQLValues
' (SS,06/07/11) Added Function GetSQL2Values, renamed GetSQLValues to GetSQL3Values
' (SS,07/07/11) Removed fieldname parameter from GetSQLValue and GetSQLValueAsString
' (SS,14/07/11) Added Functions NthSeparatedValue, ParseInt, StrCount
' (SS,15/07/11) Added Function CleanStrForFileName
' (SS,25/07/11) Removed all "If gbDebugOn And gnDebugLevel > 1" etc and left just the DebugLog, now need because DebugLog does the checks for gbDebugOn
' but modified the call to DebugLog to include the level as the first parameter
' (SS,26/07/11) Added Function HTMLDecode
' (SS,01/08/11) Changes to DebugLog to always output when ALevel is -1
' (SS,24/11/11) Added new function CleanNum, changed to GetSQLValueAsString to make sure string is returned
' (SS,16/02/12) Added new function ParagraphiseText to replaced linefeeds with HTML paragraphs or line breaks
' Change to function GetLookupCombo to add id to select, to allow adding event easier with jquery
' (SS,20/02/12) Added new routines SetCookie and GetCookie
' (SS,10/05/12) Added new function GetSQLRecordExists
' (SS,01/06/12) Bugfix to Function URLDecode to check for empty string instead of null
' (SS,13/06/12) Added new Function NNULL, to return null as NULL string
' (SS,13/06/13) Refinements to CleanSQLStr
' (SS,18/06/12) New function GetRandomPassword
' (SS,20/09/12) New encryption functions AES_EncryptHex and AES_DecryptHex
' (SS,26/09/12) Added new routines GetTextFromURL, AddFieldToQueryString and AddRecordToFile
' (SS,28/09/12) Added FTPFile, also Const TEMP_FOLDER
' (SS,18/01/13) Added function ShuffleArray
' (SS,14/02/13) Replaced function ReplaceStr with new version which calls built-in Replace
' (SS,20/02/13) Change to function ReplaceStr to fix invalid use of Null error
' (SS,07/03/13) New functions SessionVarList and SessionVarSingle
' (SS,08/03/13) Added function SpacesToNBS
' (SS,12/03/13) Added function GetLastQueryStringValue
' (SS,22/03/13) Added include of common/asp/rijndael.asp for AES encryption (Sage Pay)
' (SS,02/06/14) Added function IPAddressToInt
' (SS,22/08/14) Added function TrimBRs and function ParseFloat
' (SS,08/09/14) Added "On Error GoTo 0" to function FunctionExists to fix issue when calling routine also makes use of On Error Resume Next
' (SS,17/10/14) Added Function ParseFirstInt
' (SS,18/02/15) Change to Function SplitPostcode to handle special London postcodes like SW1A 2AA, EC2M 2RH, E1W 2AB. Changed to Function CorrectPostcodeForUK to remove hyphens.
' (SS,26/02/15) Added Sub TempDebugLog to always log to the temp folder, also added Sub DeleteCookie to delete cookies
' (SS,01/03/15) Change to HTMLEncodeSpecialChars added Chr(150) "–" and Chr(151) "—" to fix errors shown in W3C Validator
' Change to Function GetListCombo to add id to combo, help with "label for" and remove W3C validation error
' (SS,18/03/15) Added Sub SetSettingDateTimeNow
' (SS,19/03/15) Modified Function CorrectPostcodeForUK to convert letter "O" in first char of last section to digit zero, some customers are entering letter instead of digit
' Added function ISODate
' (SS,10/12/15) Added Function GetWebPage
' (SS,07/01/16) Added Function GetWebPageContents from apputils.asp, isn't no longer used, use for example to improve error handling in new GetWebPage
' (SS,27/04/17) Added Sub FetchRecordToSession, Function FetchFieldFromSession used by special token fetching
' (SS,30/06/17) Bugfix to Function TrimBRs
' (SS,18/04/18) Change to Sub WebDebugLog, to move main code to new function GetWebLog. Also a bugfix to prevent crash when session variable is an object.
' (SS,25/04/18) Added Function GetWebPageViaPOST
' (SS,16/11/18) Added functions StripHTMLTags, EscapeHTMLAngleBrackets and CleanRequestForm to prevent HTML injection on form fields.
' (SS,20/11/18) Added functions CleanRequestQueryString and CleanRequest
' (SS,07/04/19) Added function GetSQL4Values and GetSQL5Values, change to GetSQL3Values to call GetSQL4Values. Also add contants StreamTypeEnum and SaveOptionsEnum
' (SS,11/04/19) Added function JavaScriptStrEscape, better to use this instead of SingleQuotedJavascriptString and DoubleQuotedJavascriptString
' (SS,17/09/20) Added include for common/asp/jsonObject.class.asp (2nd line)
' (SS,01/07/21) Added function AddNewlinesToHTMLBreaks
' (SS,01/07/21) Added function CleanSQLStrMax from apputils.asp
' (SS,03/06/22) Added functions GetSelectQueryCount and GetExecQueryCount, change to function GetSQLRecordExists to add call to IncValueQueryCount
' Added sub IncMoveFirstQueryCount, change to GetQueryRecordCount to call FirstQueryRecord once (not twice)
' (SS,22/06/22) Change to Sub SetCookie to set cookie to secure
' (SS,01/08/22) Changes to improve error handling for SQL select and execute statements, changes made to various rouines include OpenQuery, OpenQuery2, OpenQuery3, ExecuteQuery, OpenQueryCommon, ExecuteQueryCommon...
' New routines added including HandleSQLError, SQLSelect, SQLSelectCommon, SQLSelectMain, SQLExecute, SQLExecuteCommon, SQLExecuteMain.
' Not all routines fully tested.
' ADO constants used here
' take from adovbs.inc (which is 500 lines long)
'---- CursorTypeEnum Values ----
Const adOpenDynamic = 2
'---- LockTypeEnum Values ----
Const adLockOptimistic = 3
'---- CommandTypeEnum Values ----
Const adCmdText = &H0001
Const adCmdTable = &H0002
'---- StreamTypeEnum Values ---- (SS,7/4/19)
Const adTypeBinary = 1
Const adTypeText = 2
'---- SaveOptionsEnum Values ---- (SS,7/4/19)
Const adSaveCreateNotExist = 1
Const adSaveCreateOverWrite = 2
Const LOG_FOLDER = "d:\logs\asp\" ' (SS,27/5/10) may be best to hold this in the global.asa file in future
Const TEMP_FOLDER = "d:\logs\asp\temp\" ' (SS,28/9/12)
Const BR = "<br />" ' (SS,3/6/11)
Dim oConn, oConnCommon, oRS, oRS2, oRS3, oRScommon, nRecs, gsADOErrors, gbDatabaseOpen, gbQueryOpen, gsErrorMessage
Dim gbDebugOn, gnDebugLevel, gbDebugLogType, gnStartTimer, gnDebugCount
Dim gnOpenDatabaseCount, gnCloseDatabaseCount, gnOpenQueryCount, gnCloseQueryCount, gnExecQueryCount, gnValueQueryCount
Dim gnMoveFirstQueryCount ' (SS,3/6/22)
Dim gsSelectClass ' (SS,20/6/11)
Dim gnUniqueCount ' (SS,22/6/11)
Dim gbAppStatusOn ' (SS,4/6/22)
InitialiseDBFunctions
' (SS,27/5/10) moved setting defaults for globals here
Sub InitialiseDBFunctions
gnStartTimer = Timer ' (SS,26/6/22) also used in SQL error log, noticed it was only being set in Sub DebugOn, added here otherwise it'll show seconds since midnight
gbDatabaseOpen = False
gbQueryOpen = False
gbDebugOn = False
gnDebugLevel = 1
gsErrorMessage = ""
gnOpenDatabaseCount = 0
gnCloseDatabaseCount = 0
gnOpenQueryCount = 0
gnCloseQueryCount = 0
gnExecQueryCount = 0
gnValueQueryCount = 0 ' (SS,28/5/10)
gnMoveFirstQueryCount = 0 ' (SS,3/6/22)
gnDebugCount = 0 ' (SS,27/5/10)
gnUniqueCount = 0 ' (SS,22/6/11)
gbAppStatusOn = False ' (SS,5/6/22)
SetDebug ' (SS,27/5/10) sets the debug mode if requested
SetSelectClass "form" ' (SS,20/6/11)
End Sub
' (SS,27/5/10) called from end of page e.g. apputils
Sub FinaliseDBFunctions
If gbDebugOn Then
ShowOpenDatabaseCount
DebugLog 0, "=== END OF PAGE ==="
DebugLog 0, ""
End If
End Sub
' (SS,02/02/10) added following to disable caching of the main products.asp page
' to help prevent problems on some PCs probably due to IE being set to never check for new pages, or Proxy server
' see http://support.microsoft.com/kb/234067
' called from inc-template-main.asp just after head tag
' (SS,27/5/10) moved here from apputils, also added If Session("CacheOn") to allow caching to be enabled
Sub DisableCache
If Session("CacheOn") <> True Then ' i.e. not False and ""
Response.CacheControl = "no-cache"
Response.AddHeader "Pragma", "no-cache"
Response.Expires = -1
End If
End Sub
'----------------- start of common database routines ------------------------
' (SS,18/9/06) opens the common mysql database
' (SS,26/5/07) modified to use oConnCommon instead of calling OpenDatabaseConnection
Sub OpenDatabaseCommon
DebugLog 1, "OpenDatabaseCommon called"
Set oConnCommon = Server.CreateObject("ADODB.Connection")
oConnCommon.ConnectionString = "DSN=MySQL_common;"
oConnCommon.Open
gsADOErrors = ""
End Sub
' (SS,26/5/07) new that works with oConnCommon
Sub CloseDatabaseCommon
DebugLog 1, "CloseDatabaseCommon called"
oConnCommon.Close
Set oConnCommon = Nothing
End Sub
' (SS,26/5/07) common database version
Sub OpenQueryCommon(ASQL)
DebugLog 1, "OpenQueryCommon called with " & ASQL
IncOpenQueryCount ' (SS,27/5/07)
' Set oRScommon = oConnCommon.Execute(ASQL, nRecs, adCmdText) ' (SS,28/10/09) replaced oRS with oRScommon
' (SS,1/8/22) replaced above with following for improved error handling
SQLSelectCommon "OpenQueryCommon", ASQL, oRScommon, nRecs
End Sub
' (SS,26/5/07) common database version
Sub CloseQueryCommon
DebugLog 1, "CloseQueryCommon called"
IncCloseQueryCount ' (SS,27/5/07)
oRScommon.Close ' (SS,28/10/09) replaced oRS with oRScommon
Set oRScommon = Nothing ' (SS,28/10/09) replaced oRS with oRScommon
End Sub
' (SS,28/10/09) common database version
Function EndOfQueryCommon
EndOfQueryCommon = oRScommon.Eof
End Function
' (SS,28/10/09) common database version
Sub NextQueryRecordCommon
DebugLog 2, "NextQueryRecordCommon called" ' (SS,27/5/10)
oRScommon.MoveNext
End Sub
' (SS,28/10/09) common database version
Function GetQueryValueCommon(AFieldName)
DebugLog 2, "GetQueryValueCommon called with " & AFieldName
GetQueryValueCommon = oRScommon(AFieldName)
End Function
'----------------- end of common database routines ------------------------
' (SS,30/09/03) special version for MySQL '
' (SS,18/9/06) modified to now call OpenDatabaseConnection
Sub OpenDatabase
gnOpenDatabaseCount = gnOpenDatabaseCount + 1
OpenDatabaseConnection(Application("ConnectionString"))
End Sub
Sub OpenDatabaseConnection(AConnection)
DebugLog 1, "OpenDatabase called"
' open database if not already open '
If Not gbDatabaseOpen Then
Set oConn = Server.CreateObject("ADODB.Connection")
oConn.ConnectionString = AConnection
oConn.Open
gbDatabaseOpen = True
gsADOErrors = ""
' (SS,5/6/22) added start time for timing in MySQL
oConn.Execute "SET @start_time = NOW(6)"
' (SS,26/6/22) + ---- for debugging
' oConn.Execute "SET SESSION lock_wait_timeout = 5"
End If
End Sub
Sub CloseDatabase
gnCloseDatabaseCount = gnCloseDatabaseCount + 1
DebugLog 1, "CloseDatabase called"
If gbDatabaseOpen Then
' (SS,5/6/22) app stats enabled then call save_app_stats stored procedure
If gbAppStatusOn Then SaveAppStats
oConn.Close
Set oConn = Nothing
gbDatabaseOpen = False
End If
End Sub
' (SS,17/10/06)
Function IsDatabaseOpen
IsDatabaseOpen = gbDatabaseOpen
End Function
' (SS,5/6/22)
Sub SetAppStatsOn
gbAppStatusOn = True
End Sub
' (SS,5/6/22) records the given stat in session e.g. PageType, ScriptName
Sub SetAppStat(AName, AValue)
Session("AS_" + AName) = AValue
End Sub
' (SS,5/6/22)
Function GetAppStat(AName)
GetAppStat = Session("AS_" + AName)
End Function
' (SS,3/6/22) collects stats to measure performance of web pages, including time, queries
Sub SaveAppStats
Dim LSelectQueryCount, LExecQueryCount, LIPAddress, LQueryString
LSelectQueryCount = gnOpenQueryCount + gnValueQueryCount + gnMoveFirstQueryCount
LExecQueryCount = gnExecQueryCount
LIPAddress = Request.ServerVariables("REMOTE_ADDR")
LQueryString = Request.ServerVariables("QUERY_STRING")
On Error Resume Next ' to prevent crash if error occurs here
ExecuteQuery "CALL save_app_stats('" & GetAppStat("PageType") & "', '" & CleanSQLStrMax(GetAppStat("ScriptName"), 50)& "', " & LSelectQueryCount & ", " & LExecQueryCount & ", '" & CleanSQLStrMax(LIPAddress, 45) & "', '" & CleanSQLStrMax(LQueryString, 255) & "')"
' check for error
If Err.Number <> 0 Then
LogErrorToFile("Following error occurred while in CollectStats: " & Err.Description)
End If
On Error GoTo 0 ' cancel the error handling
End Sub
' (SS,16/3/15) used to preserve the currency recordset, allows recursive use of OpenQuery, EndOfQuery, NextQueryRecord, GetQueryValue, GetQueryField etc.
' i.e. functions using oRS
Sub PreserveQuery(ByRef AoRS)
AoRS = oRS
End Sub
' (SS,16/3/15) used in conjunction with PreserveQuery above, to restore the recordset, if used recursively
Sub RestoreQuery(AoRS)
End Sub
' (SS,26/6/22) replaced oConn.Execute with SQLSelect for improved error handling
Sub OpenQuery(ASQL)
If gbQueryOpen Then CloseQuery ' if query already open then close it first
DebugLog 1, "OpenQuery called with " & ASQL
IncOpenQueryCount ' (SS,27/5/07)
'Set oRS = oConn.Execute(ASQL, nRecs, adCmdText)
' (SS,26/6/22) replaced above with following for improved error handling
SQLSelect "OpenQuery", ASQL, oRS, nRecs
gbQueryOpen = True
End Sub
Sub CloseQuery
DebugLog 1, "CloseQuery called"
If gbQueryOpen Then
IncCloseQueryCount ' (SS,27/5/07)
oRS.Close
Set oRS = Nothing
gbQueryOpen = False
End If
End Sub
Function EndOfQuery
EndOfQuery = oRS.Eof
End Function
Sub NextQueryRecord
DebugLog 2, "NextQueryRecord called" ' (SS,27/5/10)
oRS.MoveNext
End Sub
' (SS,10/10/01)
' (SS,3/6/22) discovered from query log that MoveFirst actually repeats the query (a bit pointless, added IncMoveFirstQueryCount counter to keep track
Sub FirstQueryRecord
DebugLog 1, "FirstQueryRecord called" ' (SS,27/5/10), (SS,3/6/22) changed 2 to 1
IncMoveFirstQueryCount ' (SS,3/6/22)
oRS.MoveFirst
End Sub
' (SS,27/5/07)
Sub IncOpenQueryCount
gnOpenQueryCount = gnOpenQueryCount + 1
End Sub
' (SS,27/5/07)
Sub IncCloseQueryCount
gnCloseQueryCount = gnCloseQueryCount + 1
End Sub
' (SS,28/5/10)
Sub IncValueQueryCount
gnValueQueryCount = gnValueQueryCount + 1
End Sub
' (SS,3/6/22)
Sub IncMoveFirstQueryCount
gnMoveFirstQueryCount = gnMoveFirstQueryCount + 1
End Sub
' (SS,27/5/07)
Sub IncExecQueryCount
gnExecQueryCount = gnExecQueryCount + 1
End Sub
' (SS,25/2/02) returns query value. Null is returned if field not found '
' useful when a crosstab query does not create an expected field '
Function GetQueryValueNullIfNotFound(AFieldName)
DebugLog 2, "GetQueryValueNullIfNotFound called with " & AFieldName ' (SS,27/5/10)
GetQueryValueNullIfNotFound = Null
On Error Resume Next
GetQueryValueNullIfNotFound = oRS(AFieldName)
End Function
Function GetQueryValue(AFieldName)
DebugLog 2, "GetQueryValue called with " & AFieldName
GetQueryValue = oRS(AFieldName)
End Function
' (SS,27/7/09) alias to GetQueryValue
Function GetQueryField(AFieldName)
GetQueryField = GetQueryValue(AFieldName)
End Function
' (SS,18/5/07) RecordCount doesn't work with MySQL so devised this method
' to do a count, not efficient but fine for small record sets
' starts from first record and moves back to first record
Function GetQueryRecordCount
DebugLog 2, "GetQueryRecordCount called" ' (SS,27/5/10)
Dim LRecordCount
LRecordCount = 0
' (SS,3/6/22) discovered from query log that FirstQueryRecord i.e. oRs.MoveFirst actually repeats the query
' so ended up run query the 2 additional times here without realising, removed the following unnecessary line to reduce to one extra instead of 2
'If Not EndOfQuery Then FirstQueryRecord ' if used to prevent Either BOF or EOF is True... error
Do While Not EndOfQuery
LRecordCount = LRecordCount + 1
NextQueryRecord
Loop
If LRecordCount > 0 Then FirstQueryRecord ' if used to prevent Either BOF or EOF is True... error
GetQueryRecordCount = LRecordCount
End Function
' (SS,1/6/07)
Function FieldsExistInQuery(AFieldName)
DebugLog 2, "FieldsExistInQuery called with " & AFieldName ' (SS,27/5/10)
FieldsExistInQuery = FieldExists(oRS, AFieldName)
End Function
' (SS,27/5/07) returns true if given field exists in given table
' (SS,26/6/22) replaced oConn.Execute with SQLSelect for improved error handling
Function FieldExistsInTable(ATableName, AFieldName)
DebugLog 1, "FieldExistsInTable called with " & ATableName & ", " & AFieldName
IncOpenQueryCount ' (SS,27/5/07)
Dim LRS, LRecs, i, LFound
'Set LRS = oConn.Execute("SELECT * FROM " + ATableName + " LIMIT 0", LRecs, adCmdText)
' (SS,26/6/22) replaced above with following for improved error handling
SQLSelect "FieldExistsInTable", "SELECT * FROM " + ATableName + " LIMIT 0", LRS, nRecs
FieldExistsInTable = FieldExists(LRS, AFieldName)
LRS.Close
Set LRS = Nothing
End Function
' (SS,1/6/07) moved code here from FieldExistsInTable, called from 2 places
Function FieldExists(ARS, AFieldName)
Dim i, LFound
LFound = False
For i = 0 To ARS.Fields.Count - 1
If LCase(ARS.Fields.Item(i).Name) = LCase(AFieldName) Then
LFound = True
Exit For
End If
Next
FieldExists = LFound
End Function
' (SS,3/10/01)
' (SS,1/8/22) replaced oConn.Execute with SQLSelect for improved error handling
Sub OpenQuery2(ASQL)
DebugLog 1, "OpenQuery2 called with " & ASQL
IncOpenQueryCount ' (SS,27/5/07)
'Set oRS2 = oConn.Execute(ASql, nRecs, adCmdText)
' (SS,1/8/22) replaced above with following for improved error handling
SQLSelect "OpenQuery2", ASQL, oRS2, nRecs
End Sub
Sub CloseQuery2
DebugLog 1, "CloseQuery2 called"
IncCloseQueryCount ' (SS,27/5/07)
oRS2.Close
Set oRS2 = Nothing
End Sub
Function EndOfQuery2
EndOfQuery2 = oRS2.Eof
End Function
Sub NextQueryRecord2
DebugLog 2, "NextQueryRecord2 called" ' (SS,27/5/10)
oRS2.MoveNext
End Sub
Function GetQueryValue2(AFieldName)
DebugLog 2, "GetQueryValue2 called with " & AFieldName
GetQueryValue2 = oRS2(AFieldName)
End Function
' (SS,27/7/09) alias to GetQueryValue2
Function GetQueryField2(AFieldName)
GetQueryField2 = GetQueryValue2(AFieldName)
End Function
' (SS,16/7/09)
' (SS,1/8/22) replaced oConn.Execute with SQLSelect for improved error handling (!!! not tested due to no call to it)
Sub OpenQuery3(ASQL)
DebugLog 1, "OpenQuery3 called with " & ASQL
IncOpenQueryCount
' Set oRS3 = oConn.Execute(ASQL, nRecs, adCmdText)
' (SS,1/8/22) replaced above with following for improved error handling
SQLSelect "OpenQuery3", ASQL, oRS3, nRecs
End Sub
' (SS,16/7/09)
Sub CloseQuery3
DebugLog 1, "CloseQuery3 called"
IncCloseQueryCount ' (SS,27/5/07)
oRS3.Close
Set oRS3 = Nothing
End Sub
' (SS,16/7/09)
Function EndOfQuery3
EndOfQuery3 = oRS3.Eof
End Function
' (SS,16/7/09)
Sub NextQueryRecord3
DebugLog 2, "NextQueryRecord3 called" ' (SS,27/5/10)
oRS3.MoveNext
End Sub
' (SS,16/7/09)
Function GetQueryValue3(AFieldName)
DebugLog 2, "GetQueryValue3 called with " & AFieldName
GetQueryValue3 = oRS3(AFieldName)
End Function
' (SS,27/7/09) alias to GetQueryValue3
Function GetQueryField3(AFieldName)
GetQueryField3 = GetQueryValue3(AFieldName)
End Function
' (SS,26/6/22) replaced oConn.Execute with SQLExecute for improved error handling
Sub ExecuteQuery(ASQL)
' On Error Resume Next '
DebugLog 1, "ExecuteQuery called with " & ASQL
IncExecQueryCount ' (SS,27/5/07)
'oConn.Execute(ASQL)
' (SS,26/6/22) replaced above with following
SQLExecute "ExecuteQuery", ASQL
' CheckForADOErrors(oConn)
End Sub
' (SS,14/9/07)
' (SS,1/8/22) replaced oConnCommon.Execute with SQLExecuteCommon for improved error handling (!!! not tested)
Sub ExecuteQueryCommon(ASql)
' On Error Resume Next '
DebugLog 1, "ExecuteQueryCommon called with " & ASql
IncExecQueryCount
' oConnCommon.Execute(ASql)
' (SS,1/8/22) replaced above with following
SQLExecuteCommon "ExecuteQueryCommon", ASQL
End Sub
' (SS,11/5/01)
' (SS,1/8/22) replaced oConn.Execute with SQLSelect for improved error handling (!!! not tested due to no call to it)
Function CheckKeyExists(ATableName, AFieldName, AValue)
Dim LoRS
' Set LoRS = oConn.Execute("SELECT * FROM " + ATableName + " WHERE " + AFieldName + "=" + AValue, nRecs, adCmdText)
' (SS,1/8/22) replaced oConn.Execute with SQLSelect for improved error handling (!!! not tested due to no call to it)
SQLSelect "CheckKeyExists", "SELECT * FROM " + ATableName + " WHERE " + AFieldName + "=" + AValue, LoRS, nRecs
CheckKeyExists = not LoRS.Eof
LoRS.Close
Set LoRS = Nothing
End Function
' (SS,15/5/01) '
Sub OpenTable(ATableName)
DebugLog 1, "OpenTable called"
Set oRS = Server.CreateObject("ADODB.Recordset")
oRS.Open ATableName, oConn, adLockOptimistic, adCmdTable
'oRS.Open ATableName, oConn, 1, ,2 '
' rsProds.Open "products", strProvider, 1, , adCmdTable '
End Sub
' (SS,22/10/01) add because FindFirstRecord is too slow '
' opens recordset and find the record in ACriteria '
Sub OpenTableRecordForEdit(ATableName, ACriteria)
Dim LSQL
Set oRS = Server.CreateObject("ADODB.Recordset")
LSQL = "SELECT * FROM " + ATableName + " WHERE " + ACriteria
oRS.Open LSQL, oConn, adOpenDynamic, adLockOptimistic, adCmdText
End Sub
' (SS,15/5/01) '
Sub CloseTable
DebugLog 1, "CloseTable called"
' On Error Resume Next
oRS.Close
Set oRS = Nothing
' CheckForADOErrors(oConn)
End Sub
' (SS,15/5/01) must be a better and quicker way, using Locate, FindFirst or something '
' will it work in SQL? '
Function FindRecord(AFieldName, AValue)
Dim LFound
oRS.MoveFirst
LFound = False
Do Until oRS.EOF or LFound
If oRS(AFieldName) & "" = AValue & "" then
LFound = True
Else
oRS.MoveNext
End If
Loop
FindRecord = LFound
End Function
' (SS,19/7/01) for ADO '
Function FindFirstRecord(ACriteria)
oRS.Find ACriteria
FindFirstRecord = Not oRS.EOF
End Function
' (SS,15/5/01) '
Sub EditRecord
End Sub
' (SS,15/5/01) '
Sub AddRecord
oRS.AddNew
End Sub
' (SS,26/2/02) '
Function GetFieldValue(AFieldName)
DebugLog 2, "GetFieldValue called with " & AFieldName ' (SS,27/5/10)
GetFieldValue = oRS(AFieldName)
End Function
' (SS,15/5/01) '
Sub PutFieldValue(AFieldName, AValue)
' On Error Resume Next
oRS(AFieldName) = AValue
' CheckForADOErrors(oConn)
End Sub
' (SS,15/5/01) '
' (SS,3/10/01) added error handling '
Sub PostRecord
' On Error Resume Next
oRS.Update
' CheckForADOErrors(oConn)
End Sub
' 6/10/03 runs a query and returns the value from given field, null is returned if no records found
' (SS,1/7/11) modified to assume first field is AFieldName is ""
' (SS,26/6/22) replaced oConn.Execute with SQLSelect for improved error handling
Function GetValueFromQuery(AFieldName, ASQL)
DebugLog 1, "GetValueFromQuery called with " & AFieldName & ", " & ASQL
IncValueQueryCount ' (SS,28/5/10)
Dim LoRS
' Set LoRS = oConn.Execute(ASQL, nRecs, adCmdText)
' (SS,26/6/22) replaced above with following for improved error handling
SQLSelect "GetValueFromQuery", ASQL, LoRS, nRecs
If LoRS.Eof Then
GetValueFromQuery = Null
Else
' (SS,1/7/11) add first field if blank field name
If AFieldName = "" Then
GetValueFromQuery = LoRS.Fields.Item(0) ' first field
Else
GetValueFromQuery = LoRS(AFieldName)
End If
End If
LoRS.Close
Set LoRS = Nothing
End Function
' (SS,26/6/22) all calls to oConn.Execute now go via this routine for improved error handling
' (SS,1/8/22) modified to call SQLSelectMain which is also called for common database as well via AConn parameter
Sub SQLSelect(ARoutineName, ASQL, ByRef AoRS, ByRef ARecs)
SQLSelectMain oConn, ARoutineName, ASQL, AoRS, ARecs
End Sub
' (SS,1/8/22) common database version
Sub SQLSelectCommon(ARoutineName, ASQL, ByRef AoRS, ByRef ARecs)
SQLSelectMain oConnCommon, ARoutineName, ASQL, AoRS, ARecs
End Sub
' (SS,26/6/22) all calls to oConn.Execute now go via this routine for improved error handling
' (SS,1/8/22) renamed from SQLSelect to SQLSelectMain, added AConn parameter also called from SQLSelectCommon (and new SQLSelect)
Sub SQLSelectMain(AConn, ARoutineName, ASQL, ByRef AoRS, ByRef ARecs)
On Error Resume Next ' (SS,26/6/22)
Set AoRS = AConn.Execute(ASQL, nRecs, adCmdText) ' (SS,1/8/22) replaced oConn with AConn
' (SS,26/6/22) error handling and logging
If Err.Number <> 0 Then
HandleSQLError ARoutineName, ASQL
On Error GoTo 0 ' cancel the error handling
SQL_ERROR_SEE_LOG_FOR_DETAILS ' reraise an error to abort, will cause "Variable is undefined 'SQL_ERROR_SEE_LOG_FOR_DETAILS'" error
End If
On Error GoTo 0 ' cancel the error handling
End Sub
' (SS,26/6/22) all calls to oConn.Execute now go via this routine for improved error handling
' (SS,1/8/22) modified to call SQLExecuteMain which is also called for common database as well via AConn parameter
Sub SQLExecute(ARoutineName, ASQL)
SQLExecuteMain oConn, ARoutineName, ASQL
End Sub
' (SS,1/8/22) common database version
Sub SQLExecuteCommon(ARoutineName, ASQL)
SQLExecuteMain oRScommon, ARoutineName, ASQL
End Sub
' (SS,26/6/22) all calls to oConn.Execute now go via this routine for improved error handling
' (SS,1/8/22) renamed from SQLExecute to SQLExecuteMain, added AConn parameter also called from SQLExecuteCommon (and new SQLExecute)
Sub SQLExecuteMain(AConn, ARoutineName, ASQL)
On Error Resume Next
AConn.Execute(ASQL) ' (SS,1/8/22) replaced oConn with AConn
' (SS,26/6/22) error handling and logging
If Err.Number <> 0 Then
HandleSQLError ARoutineName, ASQL
On Error GoTo 0 ' cancel the error handling
SQL_ERROR_SEE_LOG_FOR_DETAILS ' reraise an error to abort, will cause "Variable is undefined 'SQL_ERROR_SEE_LOG_FOR_DETAILS'" error
End If
On Error GoTo 0 ' cancel the error handling
End Sub
' (SS,26/6/22) special SQL error handling routine which logs error to file
Sub HandleSQLError(ARoutineName, ASQL)
Dim LErrorMessage
LErrorMessage = Err.Description & Chr(9) & ARoutineName & Chr(9) & ReplaceStr(ASQL, NL, " ")
' DEBUG *** following to be removed
'Response.Write ReplaceStr(LErrorMessage, Chr(9), BR) & BR
AddToLogFile LErrorMessage, LOG_FOLDER & "SQL_ERRORS_" & Request.ServerVariables("HTTP_HOST") & ".txt", True
End Sub
' (SS,30/6/11) runs given SELECT SQL and returns given field, if field specified is blank, then first field value is returned
' created from GetSQLValue in Delphi itpDBUtils, if value not found then Null is returns
' (SS,1/7/11) changed to alias of GetValueFromQuery, a routine created in 2003 that I discovered later, with parameters reversed
' (SS,7/7/11) removed AFieldNameToReturn
Function GetSQLValue(ASQL)
GetSQLValue = GetValueFromQuery("", ASQL)
End Function
' (SS,30/6/11) same as GetSQLValue but returns a string, useful when Null is required as ""
' (SS,7/7/11) removed AFieldNameToReturn
' (SS,24/11/11) added CStr to ensure it's string
Function GetSQLValueAsString(ASQL)
Dim LResult
LResult = GetSQLValue(ASQL)
If IsNull(LResult) Then
LResult = ""
Else
LResult = CStr(LResult) ' (SS,24/11/11)
End If
GetSQLValueAsString = LResult
End Function
' (SS,1/7/11) similar to GetSQLValue, but returns up to 3 values, returns False if record not found, and values not set
' (SS,7/4/19) added AValue4, AValue5, and renamed from GetSQL3Values to GetSQL5Values
' (SS,1/8/22) replaced oConn.Execute with SQLSelect for improved error handling
Function GetSQL5Values(ASQL, ByRef AValue1, ByRef AValue2, ByRef AValue3, ByRef AValue4, ByRef AValue5)
DebugLog 1, "GetSQLValues called with " & ASQL
IncValueQueryCount
Dim LoRS
' Set LoRS = oConn.Execute(ASQL, nRecs, adCmdText)
' (SS,1/8/22) replaced above with following for improved error handling
SQLSelect "GetSQL5Values", ASQL, LoRS, nRecs
If LoRS.Eof Then
GetSQL5Values = False
Else
If LoRS.Fields.Count >= 1 Then AValue1 = LoRS.Fields.Item(0) ' first field
If LoRS.Fields.Count >= 2 Then AValue2 = LoRS.Fields.Item(1) ' second field
If LoRS.Fields.Count >= 3 Then AValue3 = LoRS.Fields.Item(2) ' third field
If LoRS.Fields.Count >= 4 Then AValue4 = LoRS.Fields.Item(3) ' fourth field
If LoRS.Fields.Count >= 5 Then AValue5 = LoRS.Fields.Item(4) ' fifth field
GetSQL5Values = True
End If
LoRS.Close
Set LoRS = Nothing
End Function
' (SS,7/4/19) new for 4 values
Function GetSQL4Values(ASQL, ByRef AValue1, ByRef AValue2, ByRef AValue3, ByRef AValue4)
Dim LSpare
GetSQL4Values = GetSQL5Values(ASQL, AValue1, AValue2, AValue3, AValue4, LSpare)
End Function
' (SS,1/7/11) similar to GetSQLValue, but returns up to 3 values, returns False if record not found, and values not set
' (SS,7/4/19) rewritten to call new GetSQL4Values
Function GetSQL3Values(ASQL, ByRef AValue1, ByRef AValue2, ByRef AValue3)
Dim LSpare
GetSQL3Values = GetSQL4Values(ASQL, AValue1, AValue2, AValue3, LSpare)
End Function
' (SS,6/7/11) similar to GetSQLValue, but returns up to 2 values, returns False if record not found, and values not set
' calls GetSQL3Values, avoids having to define a spare variable
Function GetSQL2Values(ASQL, ByRef AValue1, ByRef AValue2)
Dim LSpare
GetSQL2Values = GetSQL3Values(ASQL, AValue1, AValue2, LSpare)
End Function
' (SS,1/7/11) returns LAST_INSERT_ID(), ID of last inserted record, as integer
Function GetSQLLastInsertID()
GetSQLLastInsertID = CLng(GetSQLValue("SELECT LAST_INSERT_ID()"))
End Function
' (SS,10/5/12) returns true if record exists, i.e. not an empty table
' this was added because GetValueFromQuery returns null when no records or field value is null, we want to know when there are no records
' *** probably need to add a separate count for this query and GetSQLLastInsertID above as well in future for stats
' (SS,1/8/22) replaced oConn.Execute with SQLSelect for improved error handling
Function GetSQLRecordExists(ASQL)
DebugLog 1, "GetSQLRecordExists called with " & ASQL
IncValueQueryCount ' (SS,3/6/22)
Dim LoRS
Set LoRS = oConn.Execute(ASQL, nRecs, adCmdText)
' (SS,1/8/22) replaced above with following for improved error handling
SQLSelect "GetSQLRecordExists", ASQL, LoRS, nRecs
If LoRS.Eof Then
GetSQLRecordExists = False
Else
GetSQLRecordExists = True
End If
LoRS.Close
Set LoRS = Nothing
End Function
' (SS,27/4/17) fetches all fields to session variables prefixed with "FR_"
' (SS,1/8/22) replaced oConn.Execute with SQLSelect for improved error handling
Sub FetchRecordToSession(ATableName, AKey)
Dim LoRS, LSQL, LKeyFieldName
' get key field name
LSQL = "SHOW COLUMNS FROM " + CleanSQLStr(ATableName) + " WHERE `Key` = 'PRI'"
'Set LoRS = oConn.Execute(LSQL, nRecs, adCmdText)
' (SS,1/8/22) replaced above with following for improved error handling
SQLSelect "FetchRecordToSession (1 of 2)", LSQL, LoRS, nRecs
If LoRS.Eof Then
LKeyFieldName = ""
Else
LKeyFieldName = LoRS("Field")
End If
LoRS.Close
Set LoRS = Nothing
' get all fields of record with given key, or first record if no key, and place in session variables
LSQL = "SELECT * FROM " + CleanSQLStr(ATableName)
If LKeyFieldName <> "" Then
LSQL = LSQL + " WHERE " + CleanSQLStr(LKeyFieldName) + " = '" & CleanSQLStr(AKey) & "'"
End If
' Set LoRS = oConn.Execute(LSQL, nRecs, adCmdText)
' (SS,1/8/22) replaced above with following for improved error handling
SQLSelect "FetchRecordToSession (2 of 2)", LSQL, LoRS, nRecs
Dim i, LFieldName, LFieldValue
For i = 0 To LoRS.Fields.Count - 1
LFieldName = LoRS.Fields.Item(i).Name
If LoRS.Eof Then
LFieldValue = "" ' if no record then set to empty string
Else
LFieldValue = LoRS.Fields.Item(i)
End If
Session("FR_" & LFieldName) = LFieldValue
' Response.Write i & ", " & LFieldName & " = " & LFieldValue & "<BR>"
Next
LoRS.Close
Set LoRS = Nothing
End Sub
' (SS,27/4/17) returns given field from session variable as already fetched by FetchRecordToSession
Function FetchFieldFromSession(AFieldName)
FetchFieldFromSession = Session("FR_" & AFieldName)
End Function
' (SS,3/10/01) developed from Wrox ASP 3.0 page 349 '
' sets global gsADOError variable to "" of no error, else message '
Function CheckForADOErrors(objConn)
Dim objError
If objConn.Errors.Count > 0 Then
' loop through the errors
For Each objError in objConn.Errors
' errors with number 0 are informational
If objError.Number <> 0 Then
gsADOErrors = gsADOErrors + objError.Description + vbCrLf
CheckForADOErrors = True
End If
Next
Else
CheckForADOErrors = False
End If
End Function
' Replace in String AStr, all occurrences of AReplace with AWith '
' (SS,14/2/13) no longer used, ReplaceStr below replaces it
Function ReplaceStrOld_removed(AStr, AReplace, AWith)
Dim p, LStr
ReplaceStr = ""
LStr = AStr
Do While LStr <> ""
p = InStr(LStr, AReplace)
If p > 0 Then
ReplaceStr = ReplaceStr + Mid(LStr, 1, p - 1) + AWith
LStr = Mid(LStr, p + Len(AReplace), Len(LStr))
Else
ReplaceStr = ReplaceStr + LStr
LStr = ""
End if
Loop
End Function
' (SS,14/2/13) replaces ReplaceStr above, now calls the built-in Replace function which should be faster
' main reason was that the version failed in an occasion with type mismatch error in the line ReplaceStr = ReplaceStr + Mid(LStr, 1, p - 1) + AWith
' probably because one of the parameters is quite a proper string as taken from MySQL table
Function ReplaceStr(AStr, AReplace, AWith)
' (SS,20/2/13) added NB to fix invalid use of Null error when AStr, AReplace or AWith is Null
ReplaceStr = Replace(NB(AStr), NB(AReplace), NB(AWith))
End Function
' (SS,15/7/11) counts how many times AStrToCount occurs in AStr
Function StrCount(AStr, AStrToCount)
Dim LResult
LResult = Len(AStr) - Len(Replace(AStr, AStrToCount, ""))
If LResult > 0 And Len(AStrToCount) > 0 Then LResult = LResult \ Len(AStrToCount)
StrCount = LResult
End Function
' (SS,20/9/01) creates lookup combo from table
' (SS,17/12/01) added AOrderField parameter to allow ordering by other fields
' (SS,16/2/04) added ASelectName parameter which overrides AFieldName to give different name for select name
' (SS,17/2/04) added AExtras to add extra to the end e.g. disabled etc.
' (SS,19/2/04) added AWhereClause to do things like WHERE Country = "United Kingdom"
' (SS,21/5/04) if ATableName starts with "SELECT" then it is used as the full SQL
' (SS,25/11/04) added AValueField, if not blank then this Field will be used to get the Value for the combo instead of AFieldName
' (SS,16/7/09) replaced with newer version from csl/book/dbfunction.asp, with few minor mods
' (SS,16/2/12) added id to the select to make selection easier in jquery to add an event
Function GetLookupCombo(ATableName, AFieldName, AOrderField, ADefaultValue, AShowBlank, ASelectName, AExtras, AWhereClause, AValueField)
Dim s, strFieldValue, LSelectName, LShowBlank, LBlankValue, LValueValue
LSelectName = AFieldName
If ASelectName <> "" Then LSelectName = ASelectName
' (SS,28/10/04) changed so that class="form" is not added if AExtras contains class=, to allow class to be overriden '
' (SS,16/02/11) added id= to make selection easier when using jquery to add an event
s = "<select id=""" + LSelectName + """ name=""" + LSelectName + """"
If InStr(LCase(AExtras), "class=") = 0 Then
s = s + GetSelectClass
End If
If AExtras <> "" Then
s = s + " " + AExtras
End If
s = s + ">"
' (SS,18/5/04) added following to allow special blank value to be passed '
If VarType(AShowBlank) = vbBoolean Then
LShowBlank = AShowBlank
LBlankValue = ""
Else
LShowBlank = True
LBlankValue = AShowBlank
End If
If LShowBlank Then
If ADefaultValue = "" Then
s = s + "<option value = """" selected>" & LBlankValue & "</option>"
Else
s = s + "<option value = """">" & LBlankValue & "</option>"
End If
End If
If AOrderField = "" Then AOrderField = AFieldName
' (SS,21/5/04) if table name start with "SELECT " then use it has the SQL else build it from table name, where and order clauses '
Dim LSQL
If UCase(Left(ATableName, 7)) = "SELECT " Then
LSQL = ATableName
Else
LSQL = "SELECT * FROM " + ATableName + Iif(AWhereClause = "", "", " WHERE " + AWhereClause) + " ORDER BY " + AOrderField
End If
OpenQuery(LSQL)
Do While Not EndOfQuery
strFieldValue = GetQueryValue(AFieldName)
If AValueField = "" Then
LValueValue = strFieldValue
Else
LValueValue = GetQueryValue(AValueField)
End If
' (SS,5/10/04) replaced "+ strFieldValue +" with "& strFieldValue &"' later LValueValue
s = s + "<option value=""" & LValueValue & """"
' (SS,5/10/04) added Trim to following to ensure values are converted to strings for comparison '
If Trim(LValueValue) = Trim(ADefaultValue) Then s = s + " selected"
' (SS,16/7/09) replaced "+ strFieldValue +" with "& strFieldValue &"'
s = s + ">" & strFieldValue & "</option>" + Chr(13) + Chr(10) ' Chr(13) + Chr(10) to made HTML more readable
NextQueryRecord
Loop
CloseQuery
s = s + "</select>"
GetLookupCombo = s
End Function
' (SS,17/2/04) '
Function GetMonthCombo(ASelectName, ADefaultValue, ABlankValue)
Dim s, i, m
s = "<select name=""" + ASelectName + """" + GetSelectClass + ">"
s = s + "<option>" & ABlankValue & "</option>"
For i = 1 to 12
m = Right("0" & i, 2)
If m = ADefaultValue Then
s = s + "<option selected>"
Else
s = s + "<option>"
End If
s = s + m + "</option>" + Chr(13) + Chr(10)
Next
s = s + "</select>"
GetMonthCombo = s
End Function
' (SS,17/2/04)
Function GetYearCombo(ASelectName, ADefaultValue, AStartYear, AEndYear, ABlankValue)
Dim s, i, y
s = "<select name=""" + ASelectName + """" + GetSelectClass + ">"
s = s + "<option>" & ABlankValue & "</option>"
For i = AStartYear To AEndYear
y = Right("000" & i, 4)
If y = ADefaultValue Then
s = s + "<option selected>"
Else
s = s + "<option>"
End If
s = s + y + "</option>" + Chr(13) + Chr(10)
Next
s = s + "</select>"
GetYearCombo = s
End Function
' (SS,17/4/09)
Function IsWorkingDay(ADate)
IsWorkingDay = Weekday(ADate) <> vbSaturday And Weekday(ADate) <> vbSunday
End Function
' (SS,17/4/09)
Function NextWorkingDay(ADate)
Dim LDate
LDate = ADate
Do
LDate = LDate + 1
Loop While Not IsWorkingDay(LDate)
NextWorkingDay = LDate
End Function
' (SS,17/4/09)
Function GetDeliveryDateCombo(ASelectName, ADefaultValue, ANoOfDays)
Dim s, i, d, LStartDate
LStartDate = NextWorkingDay(Date)
' if past midday then start from next working day
If Hour(Now) >= 12 Then LStartDate = NextWorkingDay(LStartDate)
s = "<select name=""" + ASelectName + """" + GetSelectClass + ">"
For i = 0 to ANoOfDays - 1
d = FormatDateTime(LStartDate, VbShortDate)
If d = ADefaultValue Then
s = s + "<option selected>"
Else
s = s + "<option>"
End If
s = s + d + "</option>" + Chr(13) + Chr(10)
LStartDate = NextWorkingDay(LStartDate)
Next
s = s + "</select>"
GetDeliveryDateCombo = s
End Function
' (SS,11/11/01) creates lookup combo from table, special version used to fill in values
' (SS,17/12/01) added AOrderField parameter to allow ordering by other fields
Function GetLookupFillCombo(ATableName, AFieldName1, AFieldName2, AFieldName3, AFieldName4, AOrderField, ADefaultValue, AShowBlank, AFunctionName)
Dim s, strFieldValue
s = "<select name=""u" + AFieldName1 + """ onchange=""" + AFunctionName + """>"
If AShowBlank Then
If ADefaultValue = "" Then
s = s + "<option selected></option>"
Else
s = s + "<option></option>"
End If
End If
If AOrderField = "" Then AOrderField = AFieldName1
OpenQuery("SELECT * FROM " + ATableName + " ORDER BY " + AOrderField)
Do While Not EndOfQuery
strFieldValue = GetQueryValue(AFieldName1)
If strFieldValue = ADefaultValue Then
s = s + "<option selected>"
Else
s = s + "<option>"
End If
s = s + strFieldValue
If AFieldName2 <> "" Then s = s & "; " & GetQueryValue(AFieldName2)
If AFieldName3 <> "" Then s = s & "; " & GetQueryValue(AFieldName3)
If AFieldName4 <> "" Then s = s & "; " & GetQueryValue(AFieldName4)
s = s + "</option>" + Chr(13) + Chr(10) ' Chr(13) + Chr(10) to made HTML more readable
NextQueryRecord
Loop
CloseQuery
s = s + "</select>"
GetLookupFillCombo = s
End Function
' (SS,19/10/01) yes no combo
Function GetYesNoCombo(AFieldName, ADefaultValue)
Dim s
s = "<select name=""" + AFieldName + """>" + Chr(13) + Chr(10)
If ADefaultValue = "Yes" Then
s = s + "<option>No</option>" + Chr(13) + Chr(10)
s = s + "<option Selected>Yes</option>" + Chr(13) + Chr(10)
Else
s = s + "<option Selected>No</option>" + Chr(13) + Chr(10)
s = s + "<option>Yes</option>" + Chr(13) + Chr(10)
End If
s = s + "</select>" + Chr(13) + Chr(10)
GetYesNoCombo = s
End Function
' (SS,31/5/07) returns html combo for given list, items should be separated by new lines
Function GetListCombo(ASelectName, AList, ADefaultValue, AShowBlank)
Dim LList, LShowBlank, LBlankValue, s, i, LValue
LList = Split(AList, Chr(13))
' (SS,18/5/04) added following to allow special blank value to be passed '
If VarType(AShowBlank) = vbBoolean Then
LShowBlank = AShowBlank
LBlankValue = ""
Else
LShowBlank = True
LBlankValue = AShowBlank
End If
' (SS,1/3/15) added id=""" + ASelectName + """ for "label for" to work and remove W3C validation error
s = "<select id=""" + ASelectName + """ name=""" + ASelectName + """" + GetSelectClass + ">"
If LShowBlank Then
If ADefaultValue = "" Then
s = s + "<option value = """" selected>" & LBlankValue & "</option>"
Else
s = s + "<option value = """">" & LBlankValue & "</option>"
End If
End If
For i = 0 To UBound(LList)
LValue = TrimAll(LList(i)) ' TrimAll used instead of Trim to also remove leading and trailing newline/carriage returns
s = s + "<option value=""" & LValue & """"
If LValue = ADefaultValue Then s = s + " selected"
s = s + ">" & LValue & "</option>" + Chr(13) + Chr(10) ' Chr(13) + Chr(10) to made HTML more readable
Next
s = s + "</select>"
GetListCombo = s
End Function
' (SS,20/6/11) class="form" was being used as a default, now realised that it's not necessary
Sub SetSelectClass(AClass)
gsSelectClass = AClass
End Sub
' (SS,20/6/11) if not class then returns blank, else returns class="xxx" prefixed with a space
Function GetSelectClass
If gsSelectClass = "" Then
GetSelectClass = ""
Else
GetSelectClass = " class=""" + gsSelectClass + """"
End If
End Function
' (SS,15/10/01) get access rights
Function GetAccessRights(AUserID, APassword)
GetAccessRights = "" ' default to no access rights
OpenDatabase("Main")
OpenQuery("SELECT * FROM Users WHERE UserID='" + AUserID + "' AND Password='" + APassword + "'")
If Not EndOfQuery Then
GetAccessRights = GetQueryValue("Rights")
End If
CloseQuery
CloseDatabase
End Function
' (SS,15/10/01) get access rights
Function GetAccessLevel(AAccessRights)
GetAccessLevel = 0 ' default to minimum access level
OpenDatabase("Main")
OpenQuery("SELECT * FROM Rights WHERE Rights='" + AAccessRights + "'")
If Not EndOfQuery Then
GetAccessLevel = GetQueryValue("AccessLevel")
End If
CloseQuery
CloseDatabase
End Function
' (SS,25/10/01) change password
Function ChangePassword(AUserID, APassword, ANewPassword)
ChangePassword = False ' default to not successful
OpenDatabase("Main")
OpenTableRecordForEdit "Users", "UserID='" + AUserID + "' AND Password='" + APassword + "'"
If Not EndOfQuery Then
ChangePassword = True
PutFieldValue "Password", ANewPassword
PostRecord
End If
CloseTable
CloseDatabase
End Function
Function Format2dp(ANumber)
If IsNull(ANumber) Then
Format2dp = Null
Else
Format2dp = FormatNumber(ANumber, 2, vbTrue, vbFalse, vbTrue)
End If
End Function
' (SS,11/12/08) same as Format2dp but with no commas (i.e. grouping), always returns a string, also unlike Format2dp it returns 0.00 for null
Function Format2dpnc(ANumber)
If IsNull(ANumber) Then
Format2dpnc = "0.00"
Else
Format2dpnc = FormatNumber(ANumber, 2, vbTrue, vbFalse, vbFalse)
End If
End Function
' (SS,19/9/06) rounds the number to 2dp (as Format2dp does) without adding commas, returns Double or Null
Function Round2dp(ANumber)
If IsNull(ANumber) Then
Round2dp = Null
Else
Round2dp = CDbl(FormatNumber(ANumber, 2, vbTrue, vbFalse, vbFalse)) ' (SS,28/5/07) added CDbl because FormatNumber returns a string
End If
End Function
' (SS,15/7/11) converts given string to integer, 0 is returned if not string, non numeric chars after number are ignored
' ParseInt("123ab") returns 123, ParseInt("abc") returns 0
Function ParseInt(AStr)
Dim LResult, i, LChar
LResult = ""
For i = 1 To Len(AStr)
LChar = Mid(AStr, i, 1)
If IsCharNumeric(LChar) Then
LResult = LResult + LChar
Else
Exit For
End If
Next
If LResult = "" Then LResult = "0"
ParseInt = CLng(LResult)
End Function
' (SS,17/10/14) converts first integer in given string to an integer
' ParseFirstInt("123ab") returns 123, ParseFirstInt("abc") returns 0, ParseFirstInt("abc123-45abc") returns 123
Function ParseFirstInt(AStr)
Dim LResult, i, LChar, LIntFound
LResult = ""
LIntFound = False
For i = 1 To Len(AStr)
LChar = Mid(AStr, i, 1)
If IsCharNumeric(LChar) Then
LResult = LResult + LChar
LIntFound = True
ElseIf LIntFound Then
Exit For
End If
Next
If LResult = "" Then LResult = "0"
ParseFirstInt = CLng(LResult)
End Function
' (SS,22/8/14) converts given string to double, 0 is returned if not string, non numeric chars after number are ignored
Function ParseFloat(AStr)
Dim LResult, i, LChar
LResult = ""
For i = 1 To Len(AStr)
LChar = Mid(AStr, i, 1)
If IsNumeric(LResult + LChar) Then
LResult = LResult + LChar
Else
Exit For
End If
Next
If LResult = "" Then LResult = "0"
ParseFloat = CDbl(LResult)
End Function
' Immediate If function (SS,30/4/03)
Function IIf(a, b, c)
If a Then IIf = b Else IIf = c
End Function
' (SS,21/2/02) returns null as zero, useful for calculations where null needs to be treated as zero
Function NZ(ANumber)
If IsNull(ANumber) Then
NZ = 0
Else
NZ = ENKN(ANumber) ' (SS,22/5/07) added ENKN to ensure a proper number (especially MySQL Decimal)
End If
End Function
' (SS,14/9/06) returns null as "" (i.e. Null as Blank)
Function NB(AValue)
If IsNull(AValue) Then
NB = ""
Else
' (SS,22/5/07) replaced NB = AValue with following to ensure non string is converted to a string
If VarType(AValue) = VBString Then
NB = AValue
Else
NB = CStr(AValue)
End If
End If
End Function
' (SS,13/6/12) as NB but returns null as NULL, so it can be used when setting numeric field which can be null, where '' would fail
Function NNULL(AValue)
If IsNull(AValue) Then
NNULL = "NULL"
Else
NNULL = NB(AValue)
End If
End Function
' (SS,18/5/07) converts given value to a double, if null then it returns zero
Function NZD(ANumber)
NZD = CDbl(NZ(ANumber))
End Function
' (SS,18/5/07) converts given value to a long, if null then it returns zero
Function NZL(ANumber)
NZL = CLng(NZ(ANumber))
End Function
' (SS,22/5/07) ensure number but keep null
' useful to keep original number in it's own type, but converts MySQL decimal to CDbl
Function ENKN(ANumber)
If IsNull(ANumber) Then
ENKN = Null
Else
If IsNumeric(ANumber) Then
ENKN = ANumber
Else ' else convert to double, e.g. it could be VarType 14 (MySQL Decimal), which VB thinks is not a number
ENKN = CDbl(ANumber)
End If
End If
End Function
' (SS,24/9/03)
' returns number followed by word
' e.g. PluralString(1, "product", "products") returns "1 product"
' for any other value it returns "x products"
Function PluralString(ANumber, AStringForOne, AStringForOther)
If ANumber = 1 Then
PluralString = ANumber & " " & AStringForOne
Else
PluralString = ANumber & " " & AStringForOther
End If
End Function
' cleans the string, replacing quote and apostrophe with escape char
' also converts \ with \\ so it doesn't cause problems
' with SQL statements, works with MySQL, might not with other SQL Servers
' see MySQL manual page 432 (6.1.1.1)
' (SS,14/7/09) added code for ASCII control codes etc
Function CleanSQLStr(AValue)
Dim LNewValue
If IsNull(AValue) Then
LNewValue = "" ' (SS,27/6/05) added this to prevent invalid use of null error, (SS,13/6/12) changed from AValue to LNewValue
Else
LNewValue = CStr(AValue) ' (SS,13/6/12) added CStr to ensure it converts to a string, probably not necessary, also moved to else of if
End If
' (SS,13/6/12) added "if" to only do the following if value isn't blank
If LNewValue <> "" Then
LNewValue = Replace(LNewValue, "\", "\\")
LNewValue = Replace(LNewValue, "'", "\'")
LNewValue = Replace(LNewValue, """", "\""")
' (SS,14/7/09) added following to cope with ASCII control codes (also added to CleanSQLStr in itpssutils.pas)
' see http://dev.mysql.com/doc/refman/5.0/en/string-syntax.html for escape character details
LNewValue = Replace(LNewValue, Chr(0), "\0") ' An ASCII NUL (0x00) character.
LNewValue = Replace(LNewValue, Chr(8), "\b") ' A backspace character.
LNewValue = Replace(LNewValue, Chr(9), "\t") ' A tab character.
LNewValue = Replace(LNewValue, Chr(10), "\n") ' A newline (linefeed) character.
LNewValue = Replace(LNewValue, Chr(13), "\r") ' A carriage return character.
LNewValue = Replace(LNewValue, Chr(26), "\Z") ' ASCII 26 (Control-Z).
' (SS,21/7/09) removed following because they only work for wildcard search using LIKE,
' created new function called CleanSQLStrForLike which will allow search literal % and _ in LIKE query
' problem occurred when user with underscore in email tried logging in
' it tried to search for \_ and obviously failed
' LNewValue = Replace(LNewValue, "%", "\%") ' A �%� character.
' LNewValue = Replace(LNewValue, "_", "\_") ' A �_� character.
End If
CleanSQLStr = LNewValue
End Function
' (SS,1/7/21) added here from apputils.asp
Function CleanSQLStrMax(AStr, AMaxLength)
CleanSQLStrMax = Left(CleanSQLStr(AStr), AMaxLength)
End Function
' (SS,21/7/09) calls CleanSQLStr and then converts the wildcard characters % and _ to literals
Function CleanSQLStrForLike(AValue)
Dim LNewValue
LNewValue = CleanSQLStr(AValue)
' convert the % and _ wildcard characters to literals
LNewValue = Replace(LNewValue, "%", "\%") ' A �%� character.
LNewValue = Replace(LNewValue, "_", "\_") ' A �_� character.
CleanSQLStrForLike = LNewValue
End Function
' (SS,26/6/04) '
' converts newlines to breaks for HTML '
' (SS,16/7/09) improved version from csl/book/dbfunction.asp
' (SS,17/5/11) replaced <br> with <br />
Function ConvertNewlinesToHTML(AString)
Dim LNewString
If IsNull(AString) Then
ConvertNewlinesToHTML = ""
Exit Function
End If
LNewString = Replace(AString, Chr(13) & Chr(10), BR)
' newlines may also be as either Chr(10) & Chr(13), or either Chr(10) or Chr(13) '
' so all methods are tried '
LNewString = Replace(LNewString, Chr(10) & Chr(13), BR)
LNewString = Replace(LNewString, Chr(13), BR)
LNewString = Replace(LNewString, Chr(10), BR)
ConvertNewlinesToHTML = LNewString
End Function
' (SS,17/5/11) does ConvertNewlinesToHTML and HTMLEncodeQuotesAndPounds in one call
' (SS,23/5/11) call to HTMLEncodeQuotesAndPoundsr renamed to HTMLEncodeSpecialChars
Function ConvertNewlinesEtcToHTML(AText)
Dim LText
LText = ConvertNewlinesToHTML(AText)
ConvertNewlinesEtcToHTML = HTMLEncodeSpecialChars(LText)
End Function
' (SS,1/7/21) adds newlines after HTML breaks, mainly to keep messages to less than 1000 chars per line for emails
Function AddNewlinesToHTMLBreaks(AString)
If IsNull(AString) Then
AddNewlinesToHTMLBreaks = ""
Else
AddNewlinesToHTMLBreaks = Replace(AString, BR, BR & NL)
End If
End Function
' (SS,17/5/11) encodes special quotes and pounds to display correctly in browser
' (SS,23/5/11) renamed from HTMLEncodeQuotesAndPounds to HTMLEncodeSpecialChars
' also added chr 149 and 150
' (SS,24/5/11) change to handle all chars 128 and above
' (SS,1/3/15) added Chr(150) "–" and Chr(151) "—" to fix errors shown in W3C Validator
Function HTMLEncodeSpecialChars(AText)
Dim LText
LText = AText
If IsNull(LText) Then
LText = ""
Else
' LText = Replace(LText, Chr(34), """) ' not used because it'll break HTML within text
'LText = Replace(LText, "�", "£")
'LText = Replace(LText, Chr(145), "‘")
'LText = Replace(LText, Chr(146), "’")
'LText = Replace(LText, Chr(147), "“")
'LText = Replace(LText, Chr(148), "”")
'LText = Replace(LText, Chr(149), "•") ' (SS,23/5/11) bullet character
'LText = Replace(LText, Chr(150), "–") ' (SS,23/5/11) large hypen
' (SS,24/5/11) replaced above with following to encode all chars 129 and 255
' (SS,1/3/15) added Chr(150) "–" and Chr(151) "—" to fix errors shown in W3C Validator
Dim LLen, i, c, LNew
LLen = Len(AText)
LText = ""
For i = 1 To LLen
c = Mid(AText, i, 1)
If Asc(c) < 128 Then
LText = LText + c
Else
If c = "�" Then ' i.e. Chr(163)
LNew = "£"
ElseIf c = "�" Then ' i.e. Chr(128)
LNew = "€"
ElseIf c = Chr(145) Then
LNew = "‘"
ElseIf c = Chr(146) Then
LNew = "’"
ElseIf c = Chr(147) Then
LNew = "“"
ElseIf c = Chr(148) Then
LNew = "”"
ElseIf c = Chr(149) Then
LNew = "•"
ElseIf c = Chr(150) Then
LNew = "–"
ElseIf c = Chr(151) Then
LNew = "—"
Else
LNew = "&#" & Asc(c) & ";"
End If
LText = LText + LNew
End If
Next
End If
HTMLEncodeSpecialChars = LText
End Function
' (SS,25/11/04) converts newlines to \n for Javascript alers '
' (SS,16/7/09) added from csl/book/dbfunction.asp
Function ConvertNewlinesForJavascript(AString)
Const JAVASCRIPT_NEWLINE = "\n"
Dim LNewString
If IsNull(AString) Then
ConvertNewlinesForJavascript = ""
Exit Function
End If
LNewString = Replace(AString, Chr(13) & Chr(10), JAVASCRIPT_NEWLINE)
' newlines may also be as either Chr(10) & Chr(13), or either Chr(10) or Chr(13) '
' so all methods are tried '
LNewString = Replace(LNewString, Chr(10) & Chr(13), JAVASCRIPT_NEWLINE)
LNewString = Replace(LNewString, Chr(13), JAVASCRIPT_NEWLINE)
LNewString = Replace(LNewString, Chr(10), JAVASCRIPT_NEWLINE)
ConvertNewlinesForJavascript = LNewString
End Function
' (SS,5/7/07) encode string to HTML, e.g. characters like " become "e; etc
' it actually calls Server.HTMLEncode
' (SS,22/4/09) added check for null to prevent "Type mismatch" error
Function HTMLEncode(AText)
If IsNull(AText) Then
HTMLEncode = ""
Else
HTMLEncode = Server.HTMLEncode(AText)
End If
End Function
' (SS,26/7/11) does the opposite of HTMLEncode
' from http://www.aspnut.com/reference/encoding.asp
' but wasn't happy with the for loop of 1 to 255, so added check for &# using InStr first
Function HTMLDecode(AText)
Dim i, LResult
LResult = AText
If InStr(LResult, "&") > 0 Then ' added this for speed purposes
LResult = Replace(LResult, """, Chr(34))
LResult = Replace(LResult, "<" , Chr(60))
LResult = Replace(LResult, ">" , Chr(62))
LResult = Replace(LResult, "&" , Chr(38))
LResult = Replace(LResult, " ", Chr(32))
End If
If InStr(LResult, "&#") > 0 Then ' added this for speed purposes
For i = 1 to 255
LResult = Replace(LResult, "&#" & i & ";", Chr(i))
Next
End If
HTMLDecode = LResult
End Function
' (SS,5/6/09)
Function URLEncode(AValue)
If IsNull(AValue) Then
URLEncode = ""
Else
URLEncode = Server.URLEncode(AValue)
End If
End Function
' (SS,22/9/09) following decode function taken from http://www.aspnut.com/reference/encoding.asp
' does the opposite of Server.URLEncode, Microsoft didn't include this function because it happens automatically
' when using Request.QueryString()
' (SS,1/6/12) replaced IsNull with check for = "" because "" isn't null and it was causing error in Split(0) when sConvert was ""
Function URLDecode(sConvert)
Dim aSplit
Dim sOutput
Dim I
If sConvert = "" Then ' (SS,1/6/12) was IsNull(sConvert)
URLDecode = ""
Exit Function
End If
' convert all pluses to spaces
sOutput = REPLACE(sConvert, "+", " ")
' next convert %hexdigits to the character
aSplit = Split(sOutput, "%")
If IsArray(aSplit) Then
sOutput = aSplit(0)
For I = 0 to UBound(aSplit) - 1
sOutput = sOutput & Chr("&H" & Left(aSplit(i + 1), 2)) & Right(aSplit(i + 1), Len(aSplit(i + 1)) - 2)
Next
End If
URLDecode = sOutput
End Function
' (SS,18/11/08) ensures string can be a valid javascript single quoted string literal by prefixing single quotes (') with \
Function SingleQuotedJavascriptString(AValue)
SingleQuotedJavascriptString = Replace(AValue, "'", "\'")
End Function
' (SS,18/11/08) ensures string can be a valid javascript double quoted string literal by prefixing double quotes (") with \
Function DoubleQuotedJavascriptString(AValue)
DoubleQuotedJavascriptString = Replace(AValue, """", "\""")
End Function
' (SS,11/4/19) for escaping string for JavaScript. Happens to the very similar (perhaps identical) to CleanSQLStr, so calls it
' use this in future instead of SingleQuotedJavascriptString and DoubleQuotedJavascriptString above
Function JavaScriptStrEscape(AValue)
JavaScriptStrEscape = CleanSQLStr(AValue)
End Function
' (SS,8/3/13) convert spaces to non-breaking spaces
Function SpacesToNBS(AText)
SpacesToNBS = Replace(AText, " ", " ")
End Function
' (SS,15/7/11) replaces chars not permitted for file names with "-"
Function CleanStrForFileName(AFileName)
Dim LResult, i, LLen, LChar
LLen = Len(AFileName)
LResult = ""
For i = 1 To LLen
LChar = Mid(AFileName, i, 1)
If InStr("/ ?*'"":<>\\", LChar) > 0 Then LChar = "-"
LResult = LResult + LChar
Next
CleanStrForFileName = LCase(LResult)
End Function
' 6/10/03 gets value from settings table, null is returned if not found '
' TypeID is APP, EntryID is MAIN '
' (SS,14/6/07) renamed from GetAppSetting to GetSetting, also removed TypeID = 'APP' AND EntryID = 'MAIN'
' (SS,16/7/09) renamed from GetSetting to GetSettingFromField and added AValueField parameter
' (SS,21/7/09) bug fix GetSetting = corrected to GetSettingFromField
' (SS,27/7/09) fixed bug, "SELECT FieldValue" changed to "SELECT *"
' (SS,1/8/22) replaced oConn.Execute with SQLSelect for improved error handling (!!! not tested)
Function GetSettingFromField(AGroupName, AFieldName, AValueField)
DebugLog 1, "GetSetting called with " & AGroupName & ", " & AFieldName & ", " & AValueField
Dim LoRS
' Set LoRS = oConn.Execute("SELECT * FROM Settings WHERE GroupName = '" & AGroupName & "' AND FieldName = '" & AFieldName & "'", nRecs, adCmdText)
' (SS,1/8/22) replaced above with following for improved error handling
SQLSelect "GetSettingFromField", "SELECT * FROM Settings WHERE GroupName = '" & AGroupName & "' AND FieldName = '" & AFieldName & "'", LoRS, nRecs
If LoRS.Eof Then
GetSettingFromField = Null
Else
GetSettingFromField = LoRS(AValueField) ' (SS,16/7/09) replaced "FieldValue" with AValueField
End If
LoRS.Close
Set LoRS = Nothing
End Function
' (SS,16/7/09) this replaces previous GetSetting which has been renamed to GetSettingFromField, this calls it
Function GetSetting(AGroupName, AFieldName)
GetSetting = GetSettingFromField(AGroupName, AFieldName, "FieldValue")
End Function
' (SS,16/7/09) this one returns value from MemoValue field instead of FieldValue
Function GetSettingMemo(AGroupName, AFieldName)
GetSettingMemo = GetSettingFromField(AGroupName, AFieldName, "MemoValue")
End Function
' 6/10/03, save settings to settings table, the Group and Field must already exist '
' TypeID is APP, EntryID is MAIN '
' (SS,14/6/07) renamed from SetAppSetting to SetSetting, also removed TypeID = 'APP' AND EntryID = 'MAIN'
' (SS,1/8/22) replaced oConn.Execute with SQLSelect for improved error handling (!!! not tested)
Sub SetSetting(AGroupName, AFieldName, AFieldValue)
DebugLog 1, "SetSetting called with " & AGroupName & ", " & AFieldName
' oConn.Execute("UPDATE settings SET FieldValue = '" & CleanSQLStr(AFieldValue) & "' WHERE GroupName = '" & AGroupName & "' AND FieldName = '" & AFieldName & "'")
' (SS,1/8/22) replaced above with following for improved error handling
SQLExecute "SetSetting", "UPDATE settings SET FieldValue = '" & CleanSQLStr(AFieldValue) & "' WHERE GroupName = '" & AGroupName & "' AND FieldName = '" & AFieldName & "'"
End Sub
' (SS,18/3/15) set the date/time field to now
' (SS,1/8/22) replaced oConn.Execute with SQLSelect for improved error handling
Sub SetSettingDateTimeNow(AGroupName, AFieldName)
DebugLog 1, "SetSettingDateTimeNow called with " & AGroupName & ", " & AFieldName
' oConn.Execute("UPDATE settings SET DateValue = NOW() WHERE GroupName = '" & AGroupName & "' AND FieldName = '" & AFieldName & "'")
' (SS,1/8/22) replaced above with following for improved error handling
SQLExecute "SetSettingDateTimeNow", "UPDATE settings SET DateValue = NOW() WHERE GroupName = '" & AGroupName & "' AND FieldName = '" & AFieldName & "'"
End Sub
' (SS,14/11/07) add new setting
' (SS,1/8/22) replaced oConn.Execute with SQLSelect for improved error handling (!!! not tested)
Sub AddSetting(AGroupName, AFieldName, AFieldValue)
DebugLog 1, "AddSetting called with " & AGroupName & ", " & AFieldName
' oConn.Execute("INSERT INTO settings SET GroupName = '" & AGroupName & "', FieldName = '" & AFieldName & "', FieldValue = '" & CleanSQLStr(AFieldValue) & "'")
' (SS,1/8/22) replaced above with following for improved error handling
SQLExecute "AddSetting", "INSERT INTO settings SET GroupName = '" & AGroupName & "', FieldName = '" & AFieldName & "', FieldValue = '" & CleanSQLStr(AFieldValue) & "'"
End Sub
' shows the debug message
' (SS,27/5/10) now adds to log file
' (SS,25/7/11) added ALevel parameter
' (SS,1/8/11) added special -1 check for ALevel which writes without checking for gbDebugOn
Sub DebugLog(ALevel, ADebugMessage)
' (SS,23/6/10) added this to only do when debug is on, allows direct calls from main code to log to file
If gbDebugOn Or ALevel = -1 Then
' (SS,25/7/11) added And ALevel >= gnDebugLevel (not added with And to above because of the way VB seems to call all condition of an And even if first is False)
If gnDebugLevel >= ALevel Or ALevel = -1 Then
gnDebugCount = gnDebugCount + 1 ' (SS,28/5/10)
If DebugLogTypeIsFile Then
' file name is determined from website address and session id
AddToLogFile ADebugMessage, LOG_FOLDER & Request.ServerVariables("HTTP_HOST") & "-" & Session.SessionID & ".txt", True
Else
Response.Write "*** " & ADebugMessage & " ***<br><br>"
End If
End If
End If
End Sub
' (SS,26/2/15) called directly from code to always add to a temporary log file in the temp folder, one file per host
Sub TempDebugLog(AMessage)
AddToLogFile AMessage, TEMP_FOLDER & "TempDebugLog_" & Request.ServerVariables("HTTP_HOST") & ".txt", True
End Sub
' (SS,27/6/10) adds a message to a log file, file name is log folder followed by site name (no session ID)
Sub LogErrorToFile(AErrorMessage)
AddToLogFile AErrorMessage, LOG_FOLDER & "ERRORS_" & Request.ServerVariables("HTTP_HOST") & ".txt", True
End Sub
' (SS,13/8/04)
Sub DebugOn
gbDebugOn = True
gbDebugLogType = "HTTP" ' (SS,27/5/10)
gnStartTimer = Timer ' (SS,27/5/10) used for millisecond timing in debug log
End Sub
' (SS,13/8/04)
Sub DebugOff
gbDebugOn = False
End Sub
' (SS,27/5/10)
Sub SetDebug
Dim LDebug
LDebug = Request.QueryString("debug")
If LDebug <> "" Then
If LDebug = "on" Then
Session("DebugModeOn") = True
Else ' i.e. "off"
Session("DebugModeOn") = False
End If
' set debug level if in query string "debuglevel"
Dim LDebugLevel
LDebugLevel = Request.QueryString("debuglevel")
If LDebugLevel <> "" Then SetDebugLevel CInt(LDebugLevel) ' (SS,1/7/11) replaced 2 with CInt(LDebugLevel)
Session("DebugLevel") = gnDebugLevel
End If
If Session("DebugModeOn") = True Then
DebugOn
SetDebugLevel CInt(Session("DebugLevel")) ' (SS,25/7/11) added CInt
SetDebugLogTypeToFile
DebugLog 0, "=== START OF PAGE === " & Request.ServerVariables("HTTP_HOST") & Request.ServerVariables("HTTP_URL")
If gnDebugLevel >= 3 Then WebDebugLog ' (SS,1/7/11) if level 3 or above then do the web log, which includes server variables
End If
' (SS,27/5/10) allow caching to be enabled for testing purposes
Dim LCache
LCache = Request.QueryString("cache")
If LCache <> "" Then
If LCache = "on" Then
Session("CacheOn") = True
Else ' i.e. "off"
Session("CacheOn") = False
End If
End If
End Sub
' (SS,18/9/06) outputs given debug message straight to browser
Sub DebugMsg(ADebugMessage)
Response.Write "###" & ADebugMessage & "###<br>"
End Sub
' (SS,21/5/07)
Sub SetDebugLevel(AValue)
gnDebugLevel = AValue
End Sub
' (SS,27/5/10)
Sub SetDebugLogTypeToHTTP
gbDebugLogType = "HTTP"
End Sub
' (SS,27/5/10)
Sub SetDebugLogTypeToFile
gbDebugLogType = "File"
End Sub
' (SS,27/5/10)
' (SS,1/8/11) added Or gbDebugLogType = ""
Function DebugLogTypeIsFile
DebugLogTypeIsFile = gbDebugLogType = "File" Or gbDebugLogType = ""
End Function
' (SS,26/5/07)
Sub ShowOpenDatabaseCount
DebugLog 1, "No of Database Opens : " & gnOpenDatabaseCount
DebugLog 1, "No of Database Closes : " & gnCloseDatabaseCount
DebugLog 1, "No of Query Opens : " & gnOpenQueryCount
DebugLog 1, "No of Query Closes : " & gnCloseQueryCount
DebugLog 1, "No of Value Queries : " & gnValueQueryCount ' (SS,28/5/10)
DebugLog 1, "No of MoveFirst Queries: " & gnMoveFirstQueryCount ' (SS,3/6/22)
DebugLog 1, "No of Exec Queries : " & gnExecQueryCount
End Sub
' (SS,12/8/05) converts integer to hex up to given amount of digits
' e.g. IntToHex(15, 2) returns "0F"
' IntToHex(15, 0) returns "F"
' similar to Delphi's IntToHex
Function IntToHex(Value, Digits)
Dim Result
Result = Hex(Value)
' if there are less digits that requested then left pad with zeros
If Len(Result) < Digits Then Result = Right(String(Digits, "0") + Result, Digits)
IntToHex = Result
End Function
' (SS,12/8/05) converts given hex string to integer
Function HexStrToInt(Value)
HexStrToInt = CLng("&H" & Value)
End Function
' (SS,12/8/05 converted from Delphi) encrypts a string using a simple method
' returns in hex format, can be used as a parameter
' when calling other application, because it only has
' 0123456789ABCDEF characters size will be twice as long
' as original string
' inverts each byte using XOR and reverses all characters
Function SimpleEncryptString(AStr)
Dim i, n, s, Result
Result = ""
n = Len(AStr)
For i = n To 1 Step -1 ' go through each character backwards
s = IntToHex(Asc(Mid(AStr, i, 1)) Xor &HFF, 2) ' convert to byte, invert and convert to decimal hex
Result = Result + Mid(s, 2, 1) + Mid(s, 1, 1) ' add the two nibbles in reverse
Next
SimpleEncryptString = Result
End Function
' (SS,12/8/05 converted from Delphi) opposite of SimpleEncryptString above
Function SimpleDecryptString(AStr)
Dim i, n, s
Result = ""
n = Len(AStr) \ 2
For i = n To 1 Step -1
s = Mid(AStr, i * 2, 1) + Mid(AStr, i * 2 - 1, 1) ' get the byte as hex with nibbles in reverse
Result = Result + Chr(HexStrToInt(s) Xor &HFF) ' convert the hex string to integer invert and change to char and add to result
Next
SimpleDecryptString = Result
End Function
' (SS,12/8/05) returns boolean as integer, suitable for MySQL, True returns 1, False returns 0
' (SS,1/6/07) renamed from BoolAsInt
Function BoolToInt(AValue)
If AValue then
BoolToInt = 1 ' i.e. true value
Else
BoolToInt = 0 ' i.e. false value
End If
End Function
' (SS,12/8/05) returns integer as boolean, suitable for MySQL, 1 returns True, 0 returns False
' (SS,1/6/07) renamed from IntAsBool
Function IntToBool(AValue)
' (SS,9/7/09) added IsNull(AValue) to treat null as false also
If IsNull(AValue) Or AValue = 0 then
IntToBool = False
Else
IntToBool = True
End If
End Function
' (SS,26/5/07) converts string to boolean
' true, yes, 1, -1 are retreated as True, others including Null are false, AValue must be a string or null
Function StrToBool(AValue)
Dim LResult, LValue
LResult = False
If Not IsNull(AValue) Then
LValue = LCase(AValue)
If LValue = "true" Or LValue = "yes" Or LValue = "1" Or LValue = "-1" Then LResult = True
End If
StrToBool = LResult
End Function
' (SS,28/5/07) returns true if give function exists,
' doesn't work with subs or functions with 30 parameters,
' given function will get called if it has 30 parameters
' there's no built in function in VB that does this
' required mainly to see if functions in templates exist (e.g. Shopping app)
' (SS,8/9/14) added On Error GoTo 0
Function FunctionExists(AFunctionName)
On Error Resume Next ' to trap error in following Eval function
' call the function with 20 parameters, assuming a function with 20 parameters is unlikely to occur
Eval(AFunctionName + "(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30)")
' err number will be 450 (Wrong number of arguments or invalid property assignment) if function exists
' err number will be 13 (Type mismatch) if function doesn't exist
FunctionExists = Err.Number = 450
'DebugMsg(Err.Number)
'DebugMsg(Err.Description)
' (SS,8/9/14) added following to clear the trapping of errors to prevent this routine affecting "On Error Resume Next" in routines calling this
' e.g. TryProcessOrder in apputils.asp was aborting with "Wrong number of arguments or invalid property assignment" error
On Error GoTo 0
End Function
' (SS,15/12/06) following converts given text into HTML W3C ISO etc standard
' currently just the 4 quote characters are converted
' (SS,30/5/07) was originally called ConvertToISONamedHTML
Function ToNamedHTML(AValue)
' following taken from http://theorem.ca/~mvcorks/code/charsets/named-entities.html
'145 U+2018 ‘ � ‘ � left single quotation mark
'146 U+2019 ’ � ’ � right single quotation mark
'147 U+201C “ � “ � left double quotation mark
'148 U+201D ” � ” � right double quotation mark
Dim LValue
LValue = AValue
LValue = Replace(LValue, """", """)
LValue = Replace(LValue, Chr(145), "‘")
LValue = Replace(LValue, Chr(146), "’")
LValue = Replace(LValue, Chr(147), "“")
LValue = Replace(LValue, Chr(148), "”")
ToNamedHTML = LValue
End Function
' (SS,4/6/07) the ASP Trim function only removes leading and trailing spaces
' created TrimAll which removes spaces and control characters (i.e. the same as Delphi's Trim)
' this was required because at times I also want to remove newlines and carriage returns characters
' if string is null then it's converted to a blank string ""
' (SS,23/6/09) code moved to TrimChars which handles a range of chars
' this routine now calls TrimChars for characters between 0 and 32
Function TrimAll(AString)
TrimAll = TrimChars(AString, Chr(0), Chr(32))
End Function
' (SS,23/6/09) trims given char from string
Function TrimChar(AString, ACharToTrim)
TrimChar = TrimChars(AString, ACharToTrim, ACharToTrim)
End Function
' (SS,23/6/09) trims given chars between AMinChar and AMaxChar from start and end of string
' code taken from TrimAll and modified to trim a range of chars
Function TrimChars(AString, AMinChar, AMaxChar)
Dim LString, LLen, LStart, LEnd, i
LLen = Len(AString)
LString = NB(AString)
If LString = "" Then
TrimChars = ""
Exit Function
End If
For i = 1 To LLen
If (Mid(LString, i, 1)) < AMinChar Or (Mid(LString, i, 1)) > AMaxChar Then
Exit For
End if
Next
LStart = i
LEnd = LLen
For i = LLen To 1 Step -1
If (Mid(LString, i, 1)) < AMinChar Or (Mid(LString, i, 1)) > AMaxChar Then
Exit For
End if
Next
LEnd = i
If LEnd < LStart Then
TrimChars = ""
Else
TrimChars = Mid(LString, LStart, LEnd - LStart + 1)
End If
End Function
' (SS,22/8/14) trim leading and trailing BRs i.e. <br /> added using constant BR
Function TrimBRs(AString)
Dim LString, LLen, LStart, LEnd, i, LLenBR
LLen = Len(AString)
LString = NB(AString)
If LString = "" Then
TrimBRs = ""
Exit Function
End If
LLenBR = Len(BR)
' trim leading
i = 1
Do While i < LLen
If (Mid(LString, i, LLenBR)) = BR Then
i = i + LLenBR
Else
Exit Do
End if
Loop
LStart = i
LEnd = LLen
' trim trailing
i = LLen
' (SS,30/6/17) added "And i >= LLenBR" to fix bug where Mid was failing when 2nd parameter was 0 to less, e.g. when string was 1 to 5 characters in length
Do While i > 0 And i >= LLenBR
If (Mid(LString, i - LLenBR + 1, LLenBR)) = BR Then
i = i - LLenBR
Else
Exit Do
End If
Loop
LEnd = i
If LEnd < LStart Then
TrimBRs = ""
Else
TrimBRs = Mid(LString, LStart, LEnd - LStart + 1)
End If
End Function
' (SS,21/10/08) returns true if first character of given string is alphabetic i.e. A-Z or a-z
Function IsCharAlpha(AChar)
Dim LCharCode
If AChar = "" Then
LCharCode = 0
Else
LCharCode = Asc(UCase(Left(AChar, 1)))
End If
IsCharAlpha = (LCharCode >= 65 And LCharCode <= 90) ' 65 is "A", 90 is "Z"
End Function
' (SS,21/10/08) returns true if first character of given string is a number i.e. 0-9
Function IsCharNumeric(AChar)
Dim LCharCode
If AChar = "" Then
LCharCode = 0
Else
LCharCode = Asc(UCase(Left(AChar, 1)))
End If
IsCharNumeric = (LCharCode >= 48 And LCharCode <= 57) ' 48 is "0", 57 is "9"
End Function
' (SS,24/11/11) strips all characters that are not 0 to 9 and ., e.g. CleanNum("�1,234.56") will return "1234.56", only one dot is allowed, rest ignored, if just "." then "" is returned
Function CleanNum(AStr)
Dim i, LLen, Result, LChar, LDotted
LLen = Len(AStr)
Result = ""
LDotted = False
For i = 1 To LLen
LChar = Mid(AStr, i, 1)
If LChar >= "0" And LChar <= "9" Then
Result = Result + LChar
ElseIf LChar = "." And Not LDotted Then
LDotted = True
Result = Result + LChar
End If
Next
If Result = "." Then Result = ""
CleanNum = Result
End Function
' (SS,21/10/08) strips all spaces from given string
Function StripSpaces(AString)
Dim LString, i, LLen, Result, LChar
LString = Trim(AString)
LLen = Len(LString)
Result = ""
For i = 1 To LLen
LChar = Mid(LString, i, 1)
If LChar <> " " Then Result = Result + LChar
Next
StripSpaces = Result
End Function
' (SS,19/7/10) converts given string to a more SEO friendly string
' all chars other than a-z and 0-9 are converted to hypen, max of single hyphen in a row
' e.g. "Swarovski Bambi Collection - Thumper Free Delivery" becomes swarovski-bambi-collection-thumper-free-delivery
' "Comic & Curious Cat Christmas, Log" becomes comic-curious-cat-christmas
' "The Gruffalo Soft Toy 7" (18.0cm)" becomes the-gruffalo-soft-toy-7-18-0cm
Function SEOFriendlyStr(AString)
Const SEPARATOR = "-"
Dim LString, i, LLen, Result, LChar, LPrevChar
LString = LCase(Trim(AString))
LLen = Len(LString)
Result = ""
LPrevChar = ""
For i = 1 To LLen
LChar = Mid(LString, i, 1)
If Not IsCharAlpha(LChar) And Not IsCharNumeric(LChar) Then LChar = SEPARATOR
If LChar <> SEPARATOR Or LPrevChar <> SEPARATOR Then Result = Result + LChar
LPrevChar = LChar
Next
SEOFriendlyStr = TrimChar(Result, SEPARATOR) ' also trims leading/trailing hyphens
End Function
' (SS,23/6/10) returns true if string has both lower and uppercase characters
' converted from Delphi function in itpSSUtils
Function IsMixedCase(AStr)
Dim Result, i, LHasLower, LHasUpper, LCharCode
LHasLower = False
LHasUpper = False
Result = False
For i = 1 To Len(AStr)
LCharCode = Asc(Mid(AStr, i, 1))
if LCharCode >= 65 And LCharCode <= 90 Then
LHasUpper = True
ElseIf LCharCode >= 97 And LCharCode <= 122 Then
LHasLower = True
End If
If LHasUpper And LHasLower Then
Result = True
Exit For
End If
Next
IsMixedCase = Result
End Function
' (SS,23/6/10) converts given string to proper capitalised case, if AOnlyIfSingleCase is true then it only converts if string is in a single case
' converted from Delphi function in itpSSUtils
Function ProperCase(AStrInput, AOnlyIfSingleCase)
Dim Result, i, LPrevChar, LCurrentChar
If AOnlyIfSingleCase And IsMixedCase(AStrInput) Then
Result = AStrInput
Else
LPrevChar = ""
Result = ""
For i = 1 To Len(AStrInput)
LCurrentChar = Mid(AStrInput, i, 1)
' convert to uppercase if it's the first char or previous char is not a letter and not a number
If LPrevChar = "" Or (Not IsCharAlpha(LPrevChar) And Not IsCharNumeric(LPrevChar)) then
Result = Result + UCase(LCurrentChar)
Else
Result = Result + LCase(LCurrentChar)
End If
LPrevChar = LCurrentChar
Next
End If
ProperCase = Result
End Function
' (SS,23/6/10) calls ProperCase with second parameter set to True
' converted from Delphi function in itpSSUtils
Function Proper(AStrInput)
Proper = ProperCase(AStrInput, True)
End Function
' (SS,14/7/11) returns nth separated value
' e.g. NthSeparatedValue("apple/banana/orange", "/", 2) returns "banana"
Function NthSeparatedValue(AList, ASeparator, AIndex)
Dim LSplits, LZeroBasedIndex
LSplits = Split(AList, ASeparator)
LZeroBasedIndex = AIndex - 1
If LZeroBasedIndex >= LBound(LSplits) And LZeroBasedIndex <= UBound(LSplits) Then
NthSeparatedValue = LSplits(LZeroBasedIndex)
Else
NthSeparatedValue = ""
End If
End Function
' (SS,23/6/10) correct postcode for UK only, convert to uppercase and make sure there is a space in the middle, calls CorrectPostcodeForUK
' converted from Delphi function in itpSSUtils
Function CorrectPostcode(APostcode, ACountry)
If Left(ACountry, 14) = "United Kingdom" Or Left(ACountry, 4) = "UK (" Then
CorrectPostcode = CorrectPostcodeForUK(APostcode)
Else
CorrectPostcode = APostcode
End If
End Function
' (SS,23/6/10) correct postcode for UK only, convert to uppercase and make sure there is a space in the middle
' converted from Delphi function in itpSSUtils
' (SS,18/2/15) modified to remove hyphens
' (SS,19/1/15) modified to allow letter "O" instead of digit "0" in 3 char from end, i.e. it's converted to zero
Function CorrectPostcodeForUK(APostcode)
Dim LPostcode, LLastThree
LPostcode = Replace(APostcode, "-", "") ' (SS,18/2/15) replace hyphen with a space, a buyer happened to have an hypen in their postcode
LPostcode = Trim(UCase(LPostcode))
If InStr(LPostcode, " ") = 0 And Len(LPostcode) >= 5 And Len(LPostcode) <= 7 Then
LLastThree = Right(LPostcode, 3)
' if last 3 are of the type 9AA, i.e. numeric, alpha and alpha, therefore valid then insert the missing space
If IsCharNumeric(Mid(LLastThree, 1, 1)) And IsCharAlpha(Mid(LLastThree, 2, 1)) And IsCharAlpha(Mid(LLastThree, 3, 1)) Then
LPostcode = Mid(LPostcode, 1, Len(LPostcode) - 3) + " " + LLastThree
End If
End If
' (SS,19/1/15) added following, if first of last 3 is letter "O" then convert this to "0" some customers are entering letter O instead of digit zero
LLastThree = Right(LPostcode, 3)
If Mid(LLastThree, 1, 1) = "O" Then
LPostcode = Mid(LPostcode, 1, Len(LPostcode) - 3) + " 0" + MID(LLastThree, 2)
End If
CorrectPostcodeForUK = LPostcode
End Function
' (SS,21/10/08) splits a UK postcode into its 4 parts, and returns true if it's valid
' (SS,25/5/11) minor change to always return AInwardNo even if ASuffix is missing
' (SS,18/2/15) modified to handle special extending London postcodes e.g. EC2M 2RH, SW1W 0NY, E1W 1AB
' UK Postcodes can be in the following formats: A9 9AA, A99 9AA, AA9 9AA, AA99 9AA, AA9A 9AA, A9A 9AA
' see http://en.wikipedia.org/wiki/Postcodes_in_the_United_Kingdom for more details
Function SplitPostcode(APostcode, ByRef APrefix, ByRef AOutwardNo, ByRef AInwardNo, ByRef ASuffix)
Dim LPostcode, LPostcodePrefix, LPostcodeNo, LChar, LIndexS, LIndexE, LAllowedLength
APrefix = ""
AOutwardNo = ""
AInwardNo = ""
ASuffix = ""
LAllowedLength = 5 ' minimum allowed length is 5, incremented later if prefix is 2 chars and/or outwardno is 2 chars
LPostcode = StripSpaces(UCase(APostcode))
' determine prefix
LIndexS = 1
LChar = Mid(LPostcode, LIndexS, 1)
If IsCharAlpha(LChar) Then
LIndexS = LIndexS + 1
APrefix = LChar
LChar = Mid(LPostcode, LIndexS, 1)
If IsCharAlpha(LChar) Then
LIndexS = LIndexS + 1
LAllowedLength = LAllowedLength + 1
APrefix = APrefix + LChar
End If
End If
' determine suffix, only if there is a prefix, not already at end
If APrefix <> "" Then
LIndexE = Len(LPostcode)
If LIndexS < LIndexE Then
LChar = Mid(LPostcode, LIndexE, 1)
If IsCharAlpha(LChar) Then
LIndexE = LIndexE - 1
ASuffix = LChar
LChar = Mid(LPostcode, LIndexE, 1)
If IsCharAlpha(LChar) Then
LIndexE = LIndexE - 1
ASuffix = LChar + ASuffix ' because we're going backwards
End If
End If
End If
End If
' determine inwardno, only if there is a suffix and end index points to a valid char
' (SS,25/5/11) removed [If ASuffix <> ""] because we want return the inward no even if no suffix
If LIndexE <> 0 Then
LChar = Mid(LPostcode, LIndexE, 1)
If IsCharNumeric(LChar) Then
LIndexE = LIndexE - 1
AInwardNo = LChar
End If
End If
' determine outwardno, only if there is a prefix
If APrefix <> "" Then
LChar = Mid(LPostcode, LIndexS, 1)
If IsCharNumeric(LChar) Then
LIndexS = LIndexS + 1
AOutwardNo = LChar
LChar = Mid(LPostcode, LIndexS, 1)
' 2nd number could be the inwardno if space has been missed
' therefore we only add if the char hasn't already been used as inwardno
' i.e. LIndexE >= LIndexS
' (SS,18/2/15) added Or IsCharAlpha(LChar) for special London outward codes
' e.g. EC2M 2RH, SW1W 0NY, E1W 1AB
If (IsCharNumeric(LChar) Or IsCharAlpha(LChar)) And LIndexE >= LIndexS Then
LAllowedLength = LAllowedLength + 1
AOutwardNo = AOutwardNo + LChar
End If
End If
End If
' return true if it's a full valid postcode, i.e. has all 4 parts, with prefix of 1 or 2 characters, suffix of 2 characters, outwardno of 1 or 2 and inwardno of 1 character
SplitPostcode = LAllowedLength = Len(LPostcode) And (Len(APrefix) = 1 Or Len(APrefix) = 2) And Len(ASuffix) = 2 And (Len(AOutwardNo) = 1 Or Len(AOutwardNo) = 2) And Len(AInwardNo) = 1
End Function
' (SS,17/4/09) converts given UK date in string to MySQL format for use in SQL queries '
Function ConvertUKToMySQLDate(ADate)
If IsNull(ADate) Or ADate = "" Then
' (SS,8/5/09) changed to return Null as a string so it can used directly in SQL statement
ConvertUKToMySQLDate = "Null" ' because blank date can only be saved as Null not empty string '
Else
' (SS,8/5/09) removed the two '& "-"' so it can be assigned without quotes, also added "0" for leading zero
ConvertUKToMySQLDate = DatePart("yyyy", ADate) & Right("0" & DatePart("m", ADate), 2) & Right("0" & DatePart("d", ADate), 2)
End If
End Function
' (SS,19/3/15) returns date in ISO 8601 format as a string (YYYY-MM-DD)
Function ISODate(ADate)
If IsNull(ADate) Or ADate = "" Then
ISODate = "Null"
Else
ISODate = DatePart("yyyy", ADate) & "-" & Right("0" & DatePart("m", ADate), 2) & "-" & Right("0" & DatePart("d", ADate), 2)
End If
End Function
' (SS,28/5/09) returns true if given string is a URL
Function IsURL(AURL)
Dim LStr
LStr = Trim(LCase(AURL))
IsURL = Left(LStr, 5) = "http:" Or Left(LStr, 6) = "https:" Or Left(LStr, 4) = "www."
End Function
' (SS,12/3/13) returns last query string value from given URL, i.e. the value after the last "=", returns "" if there is no value
Function GetLastQueryStringValue(AURL)
Dim LPos, LResult
LPos = InStrRev(AURL, "=")
If LPos > 0 Then
LResult = Mid(AURL, LPos + 1)
Else
LResult = ""
End If
GetLastQueryStringValue = LResult
End Function
' (SS,29/8/04) replaces new line characters with <br> for HTML formatting
' (SS,29/5/09) moved here from apputils.asp
' it actually does the same as Function ConvertNewlinesToHTML
' (SS,23/5/11) replaced <br> with <br />
Function ReplaceNewLinesWithBR(AValue)
ReplaceNewLinesWithBR = ReplaceStr(AValue, Chr(13) + Chr(10), BR)
End Function
' (SS,4/6/09) removes newlines from given string
Function RemoveNewLines(AValue)
RemoveNewLines = ReplaceStr(AValue, Chr(13) + Chr(10), "")
End Function
' (SS,12/6/09) returns random integer between the two given numbers
Function RandomInteger(AMin, AMax)
Randomize
RandomInteger = Int((AMax - AMin + 1) * Rnd + AMin)
End Function
' (SS,18/6/12) returns random password x characters long with characters 0..9, A..B, a..z
Function GetRandomPassword(ALength)
Dim i, LPassword
Const ALLOWED_LETTERS = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
Randomize
LPassword = ""
For i = 1 To ALength
LPassword = LPassword + Mid(ALLOWED_LETTERS, Int(Rnd * Len(ALLOWED_LETTERS)) + 1, 1)
Next
GetRandomPassword = LPassword
End Function
' (SS,17/1/13) randomly shuffles or jumbles up the items in the given array, i.e. puts them in a different order
Function ShuffleArray(ByVal AArray)
Dim LLower, LUpper, LSwapPos, LTemp, i
LLower = LBound(AArray)
LUpper = UBound(AArray)
Randomize Timer
' loop through swapping randomly with current element
For i = LLower To LUpper
LSwapPos = Int(Rnd * (LUpper + 1))
LTemp = AArray(i)
AArray(i) = AArray(LSwapPos)
AArray(LSwapPos) = LTemp
Next
ShuffleArray = AArray ' return the shuffled array
End Function
' (SS,23/6/09) from siteutils used to determine the clean page name in URL containing &page=
' replaces all non alpha and number characters with '-', ignores quotes and converts to lowercase
' also trims leading and trailing dashes
Function CleanPageName(APageName)
Dim i, LChar, Result
Result = ""
For i = 1 To Len(APageName)
LChar = Mid(APageName, i, 1)
If IsCharAlpha(LChar) Or IsCharNumeric(LChar) Then
Result = Result + LChar
' (SS,23/6/09) ignore quotes
ElseIf LChar <> "'" And LChar <> """" Then
Result = Result + "-"
End If
Next
' trim leading and trailing dashes
Result = TrimChar(Result, "-")
' make sure 2 and 3 dash are just one dash
Result = Replace(Result, "--", "-")
Result = Replace(Result, "--", "-")
Result = LCase(Result)
CleanPageName = Result
End Function
' (SS,3/11/04) returns true if file exists '
' (SS,16/7/09) copied from csl/book/dbfunction.asp
Function FileExists(AFileName)
Dim objFSO
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
FileExists = objFSO.FileExists(AFileName)
Set objFSO = Nothing
End Function
' (SS,3/11/04) deletes given file if it exists '' (SS,16/7/09) copied from original csl/book/dbfunction.asp
' (SS,16/7/09) copied from csl/book/dbfunction.asp
Sub DeleteFile(AFileName)
Dim objFSO
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
If FileExists(AFileName) Then objFSO.DeleteFile(AFileName)
Set objFSO = Nothing
End Sub
' (SS,4/11/04) deletes given file if it exists '
' (SS,16/7/09) copied from csl/book/dbfunction.asp
Sub CopyFile(ASourceFileName, ADestinFileName)
Dim objFSO
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
If FileExists(ASourceFileName) Then objFSO.CopyFile ASourceFileName, ADestinFileName
Set objFSO = Nothing
End Sub
' (SS,26/9/12) add a record string to given file
' if file doesn't exist then it's created
' AUsePhysicalPath must be True if full path specified e.g c:\temp\log.txt
Sub AddRecordToFile(ARecordStr, AFileName, AUsePhysicalPath)
Dim objFSO, objFile, LFileName
If AUsePhysicalPath Then
LFileName = AFileName
Else
LFileName = Server.MapPath(AFileName)
End If
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(LFileName, 8, True) ' append to file, create file if it doesn't exist
objFile.WriteLine(ARecordStr)
objFile.Close
Set objFile = Nothing
Set objFSO = Nothing
End Sub
' (SS,27/5/10) adds message with timestamp to given file, APhysicalPath must be True if full path specified e.g c:\temp\log.txt
' if no AFileName specified then log.txt is assumed as virtual path
Sub AddToLogFile(AMessage, AFileName, APhysicalPath)
Dim objFSO, objFile, LFileName
If APhysicalPath Then
LFileName = AFileName
Else
LFileName = AFileName
If LFileName = "" Then LFileName = "log.txt"
LFileName = Server.MapPath(LFileName)
End If
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(LFileName, 8, True) ' append to file, create file if it doesn't exist
If AMessage = "" Then
objFile.WriteLine("") ' blank line
Else
objFile.WriteLine(Now() & ", " & FormatNumber(Timer - gnStartTimer, 2, vbTrue, vbFalse, vbFalse) & "," & Right(" " & gnDebugCount, 4) & ", " & AMessage)
End If
objFile.Close
Set objFile = Nothing
Set objFSO = Nothing
End Sub
' (SS,20/7/10) returns minimum of two values
Function Min(A, B)
If B < A Then
Min = B
Else
Min = A
End If
End Function
' (SS,20/7/10) returns maximum of two values
Function Max(A, B)
If B > A Then
Max = B
Else
Max = A
End If
End Function
' (SS,19/5/11) converts � or � to HTML code, else returns original string
Function CurrencyCharToHTML(AChar)
Dim LResult
If AChar = Chr(163) Then
LResult = "£"
ElseIf AChar = Chr(128) Then
LResult = "€"
Else
LResult = AChar
End If
CurrencyCharToHTML = LResult
End Function
' (SS,22/6/11) returns unique number starting from one, increments by 1 on each call
Function GetUniqueCount()
gnUniqueCount = gnUniqueCount + 1
GetUniqueCount = gnUniqueCount
End Function
' (SS,1/7/2011) logs browser info and server variables, inc form values etc. into log file
' (SS,18/4/18) moved main code into separate GetWebLog function, so that it can be called to get the log as a string
Sub WebDebugLog
Dim NL
NL = Chr(13) & Chr(10)
DebugLog 0, NL & GetWebLog ' (SS,18/4/18) LBody replaced with GetWebLog
End Sub
' (SS,18/4/18) code moved here from WebDebugLog above to allow getting this as a string, also fix to crash when session variable is an object
Function GetWebLog
Dim NL
NL = Chr(13) & Chr(10)
Dim LBody, LName, LKeyName, i
LBody = ""
LBody = LBody & "----------------" & NL
LBody = LBody & "Server Date/Time" & NL
LBody = LBody & "----------------" & NL
LBody = LBody & Now & NL
LBody = LBody & NL
LBody = LBody & "----------------------" & NL
LBody = LBody & "QueryString Collection" & NL
LBody = LBody & "----------------------" & NL
For Each LName in Request.QueryString
LBody = LBody & LName & " = " & Request.QueryString(LName) & NL
Next
LBody = LBody & NL
LBody = LBody & "---------------" & NL
LBody = LBody & "Form Collection" & NL
LBody = LBody & "---------------" & NL
For Each LName in Request.Form
LBody = LBody & LName & " = " & Request.Form(LName) & NL
Next
LBody = LBody & NL
LBody = LBody & "------------------" & NL
LBody = LBody & "Cookies Collection" & NL
LBody = LBody & "------------------" & NL
For Each LName in Request.Cookies
If Request.Cookies(LName).HasKeys Then 'cookies with keys '
For Each LKeyName in Request.Cookies(LName)
LBody = LBody & LName & "(" & LKeyName & ")" & " = " & Request.Cookies(LName)(LKeyName) & NL
Next
Else ' normal cookies '
LBody = LBody & LName & " = " & Request.Cookies(LName) & NL
End If
Next
LBody = LBody & NL
LBody = LBody & "-----------------" & NL
LBody = LBody & "Session Variables" & NL
LBody = LBody & "-----------------" & NL
For Each LName in Session.Contents
If IsArray(Session(LName)) Then
For i = LBound(Session(LName)) To UBound(Session(LName))
LBody = LBody & LName & "(" & i & ")" & " = " & Session(LName)(i) & NL
Next
Else
' LBody = LBody & LName & " = " & Session.Contents(LName) & NL
' (SS,18/4/18) replaced above with following to fix error "Wrong number of arguments or invalid property assignment"
' this was occuring due to object being used in a session variable i.e. BasketPricesDict
LBody = LBody & LName & " = "
If IsObject(Session.Contents(LName)) Then
LBody = LBody & "? Object" & NL
Else
LBody = LBody & Session.Contents(LName) & NL
End If
End If
Next
LBody = LBody & NL
LBody = LBody & "----------------------" & NL
LBody = LBody & "Session Static Objects" & NL
LBody = LBody & "----------------------" & NL
For Each LName in Session.StaticObjects
LBody = LBody & LName & " = " & LName & NL
Next
LBody = LBody & NL
LBody = LBody & "---------------------" & NL
LBody = LBody & "Application Variables" & NL
LBody = LBody & "---------------------" & NL
For Each LName in Application.Contents
If IsArray(Application(LName)) Then
For i = LBound(Application(LName)) To UBound(Application(LName))
LBody = LBody & LName & "(" & i & ")" & " = " & Application(LName)(i) & NL
Next
Else
LBody = LBody & LName & " = " & Application.Contents(LName) & NL
End If
Next
LBody = LBody & NL
LBody = LBody & "--------------------------" & NL
LBody = LBody & "Application Static Objects" & NL
LBody = LBody & "--------------------------" & NL
For Each LName in Application.StaticObjects
LBody = LBody & LName & " = " & LName & NL
Next
LBody = LBody & NL
LBody = LBody & "----------------" & NL
LBody = LBody & "Server Variables" & NL
LBody = LBody & "----------------" & NL
For Each LName in Request.ServerVariables
LBody = LBody & LName & " - " & Request.ServerVariables(LName) & NL
Next
LBody = LBody & NL
GetWebLog = LBody ' (SS,18/4/18)
End Function
' (SS,16/2/12) removes leading and trailing newlines and replaces newlines with HTML paragraph tags, two linefeeds are replaced with paragraph, single with a linebreak
Function ParagraphiseText(AText)
Dim LResult
' TrimAll removes leading and trailing newlines
LResult = TrimAll(AText)
' replace newlines with ending and starting paragraph tag
LResult = ReplaceStr(LResult, Chr(13) + Chr(10) + Chr(13) + Chr(10), "</p><p>")
LResult = ReplaceStr(LResult, Chr(13) + Chr(10) + Chr(32) + Chr(13) + Chr(10), "</p><p>") ' noticed some reviews had CRLF space and CRLF, this copes with it but probably need to check for more than one space in future
LResult = ReplaceNewLinesWithBR(LResult)
' also add preceding and trailing paragraph tags
ParagraphiseText = "<p>" + LResult + "</p>"
End Function
' (SS,20/2/12) cookies must be set before sending HTML tag, otherwise they won't work
Sub SetCookie(ACookieName, ACookieValue)
Response.Cookies(ACookieName) = ACookieValue
' following used because cookie only seems to work properly in IE6 when expires is set, fine in FireFox
' maximum is Jan 19, 2038, 3:14:07 GMT, so 2037 used to be safe
Response.Cookies(ACookieName).Expires = #Dec 31,2037#
' (SS,21/6/22) added following to ensure it's a "secure" cookie, it's required for setting "SameSite" to "None" (via web.config)
Response.Cookies(ACookieName).Secure = True
End Sub
' (SS,20/2/12)
Function GetCookie(ACookieName)
GetCookie = Request.Cookies(ACookieName)
End Function
' (SS,26/2/15) deletes given cookie by expiring it, i.e. setting to previous day
Sub DeleteCookie(ACookieName)
Response.Cookies(ACookieName).Expires = DateAdd("d", -1, Now())
End Sub
' (SS,20/9/12) returns given string encrypted using given password, as a hex string using MySQL
Function AES_EncryptHex(AStringToEncrypt, APassword)
AES_EncryptHex = GetSQLValueAsString("SELECT HEX(AES_ENCRYPT('" + CleanSQLStr(AStringToEncrypt) + "', '" + CleanSQLStr(APassword) + "'))")
End Function
' (SS,20/9/12) returns string decrypted from given hex string and password, using MySQL
Function AES_DecryptHex(AHexStringToDecrypt, APassword)
' CAST is important otherwise VARBINARY is returned which ASP doesn't understand and treats as ??????
AES_DecryptHex = GetSQLValueAsString("SELECT CAST(AES_DECRYPT(UNHEX('" + CleanSQLStr(AHexStringToDecrypt) + "'), '" + CleanSQLStr(APassword) + "') AS CHAR)")
End Function
' (SS,25/9/12) returns content of given URL as a string
Function GetTextFromURL(AURL)
Dim oXMLHTTP, LResult
Set oXMLHTTP = Server.CreateObject("MSXML2.ServerXMLHTTP.3.0")
oXMLHTTP.open "GET", AURL, False
' Send the request
' following can fail with "The connection with the server was terminated abnormally" error or similar, so we trap it
On Error Resume Next
oXMLHTTP.send
If Err.Number = 0 Then ' only do the following if no error
If oXMLHTTP.status = 200 Then
LResult = oXMLHTTP.responseText
Else
LResult = "status returned = " & oXMLHTTP.status
End If
Else
LResult = Err.Description
End If
Set oXMLHTTP = Nothing
GetTextFromURL = LResult
End Function
' (SS,25/9/12) adds given field and value to query string, first value is preceded with "?", subsequent with "&"
Function AddFieldToQueryString(AQueryString, AFieldName, AFieldValue)
AddFieldToQueryString = AQueryString + Iif(AQueryString = "", "?", "&") + AFieldName + "=" + URLEncode(AFieldValue)
End Function
' (SS,27/9/12) FTP a given file, file must contain full path, ARemoteDir can be left blank
' returns True if successful, FTP log in returned in AFTPlog
' currently uses winscp held in d:\bin\winscp\, microsoft ftp fails to work on fasthosts server
' with help from http://www.aspfree.com/c/a/ASP/FTP-with-ASP/
Function FTPFile(AHost, AUser, APassword, AIsBinary, ARemoteDir, AFileName, ByRef AFTPLog)
' Const COMMAND_FTP = "ftp.exe -i -s:"
Const COMMAND_FTP = "d:\bin\winscp\winscp.com" ' winscp used because ftp doesn't work on fasthosts server
Dim objFSO, objFile, LScriptFileName
Set objFSO = CreateObject("Scripting.FileSystemObject")
' create temporary file in log folder used for saving FTO script
LScriptFileName = objFSO.GetTempName
LScriptFileName = TEMP_FOLDER & LScriptFileName & ".ftp"
If Not objFSO.FileExists(LScriptFileName) Then objFSO.CreateTextFile(LScriptFileName)
Set objFile = objFSO.OpenTextFile(LScriptFileName, 2, True)
' create the FTP script file, to login, move to folder and put the file
objFile.WriteLine("open ftp://" & AUser & ":" & APassword & "@" & AHost)
objFile.WriteLine("option batch continue")
objFile.WriteLine("option confirm off")
' If LocalDir <> "" Then objFile.WriteLine( "lcd " & LocalDir )
If ARemoteDir <> "" Then objFile.WriteLine( "cd " & RemoteDir )
If AIsBinary Then
objFile.WriteLine("binary")
Else
objFile.WriteLine("ascii")
End If
objFile.WriteLine("dir") ' (SS,27/9/12) don't ask me why, but "put" was failing in ASP (fine in called from command prompt winder), added this seemed to fix it (at least on ontheworldweb.com server)
objFile.WriteLine("put " & AFileName)
objFile.WriteLine("exit")
objFile.Close
Set objFile = Nothing
' execute the FTP command using shell
Dim objShell
Set objShell = Server.CreateObject("WScript.Shell")
' N.B. IUSR must have execute access to the command, other access, like authenticated users or user might be required too
Dim WSX
Set WSX = objShell.Exec(COMMAND_FTP & " /nointeractiveinput /script=" & LScriptFileName)
' (SS,27/9/12) added because ReadAll() can only be used once, subsequently returns a blank I think, causing further code to fail, no need to save to file like the original did
Dim LOutput
LOutput = WSX.StdOut.ReadAll
' LErrorLog = WSX.StdErr.ReadAll ' not used because it doesn't return anything
' delete the temporary script file
objFSO.DeleteFile LScriptFileName, True
Set objFSO = Nothing
' does a check and returns true if FTP succeeded
Dim objRegExp
Set objRegExp = New RegExp
objRegExp.IgnoreCase = True
' objRegExp.Pattern = "not connected|invalid command|error"
objRegExp.Pattern = "Access denied|Error|failed" ' applicable to WinScp
If objRegExp.Test(LOutput) Or InStr(LOutput, "100%") = 0 Then ' also make sure "100%" exists because it indicates that file upload succeeded
FTPFile = False
Else
FTPFile = True
End If
Set objRegExp = Nothing
AFTPLog = LOutput
End Function
' (SS,7/3/13) returns given list of session variable names and values, if AVarList is "" then all variables are returns, else just those specified in same order as list
' each name and value is separated by a new line
Function SessionVarList(AVarList)
Dim LResult, LName, i, LArray
LResult = ""
If AVarList = "" Then
For Each LName in Session.Contents
LResult = LResult & SessionVarSingle(LName)
Next
Else
LArray = Split(AVarList, ",")
For i = LBound(LArray) To UBound(LArray)
LResult = LResult & SessionVarSingle(LArray(i))
Next
End If
SessionVarList = LResult
End Function
' (SS,7/3/13) called by SessionVarList to return the details for given session variable
Function SessionVarSingle(AName)
Dim LResult, i
LResult = ""
If IsArray(Session(AName)) Then
For i = LBound(Session(AName)) To UBound(Session(AName))
LResult = LResult & AName & "(" & i & ")" & " = " & Session(AName)(i) & NL
Next
Else
LResult = LResult & AName & " = " & Session.Contents(AName) & NL
End If
SessionVarSingle = LResult
End Function
' (SS,2/6/14) converts IP address in format 80.123.78.78 to integer
Function IPAddressToInt(AIPAddress)
Dim LIPByte, s, n, LResult
LIPByte = Split(AIPAddress, ".")
LResult = 0
If UBound(LIPByte) = 3 Then
For Each s in LIPByte
If IsNumeric(s) Then
n = CInt(s)
If n >= 0 And n <= 255 Then
LResult = LResult * 256 + n
End If
End If
Next
End If
IPAddressToInt = LResult
End Function
' (SS,8/6/07) returns contents of given URL, used to send HTML emails, AURL can contain querystring
' (SS,7/1/16) this routine isn't actually used any more, GetWebPage replaces it, moved here from apputils.asp as an example to improve error handling for new GetWebPage
' *** to be removed after improving error handling for GetWebPage below
Function GetWebPageContents(AURL)
Const Request_POST = 1
Const Request_GET = 2
Dim objTear, strContents
Set objTear = CreateObject("SOFTWING.ASPtear")
On Error Resume Next
strContents = objTear.Retrieve(AURL, Request_GET, "", "", "")
If Err.Number <> 0 Then
Response.Write "<b>"
If Err.Number >= 400 Then
Response.Write "Server returned error: " & Err.Number
Else
Response.Write "Component/WinInet error: " & Err.Description
End If
Response.Write "</b>"
Response.End
End If
GetWebPageContents = strContents
End Function
' returns page content from given URL, works with SSL (https://)
' (SS,7/1/16) *** error handling to be added, see GetWebPageContents above
Function GetWebPage(AURL)
Dim objHttp
Set objHttp = Server.CreateObject("WinHTTP.WinHTTPRequest.5.1")
objHttp.Open "GET", AURL, False
' ignore certificate errors
Const WinHttpRequestOption_SslErrorIgnoreFlags = 4
objHttp.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = &H3300
objHttp.Send
GetWebPage = objHttp.ResponseText
Set objHttp = Nothing
End Function
' returns page content from given URL, works with SSL (https://)
' (SS,7/1/16) *** error handling to be added, see GetWebPageContents above
' (SS,25/4/18) similar to Function GetWebPage but uses POST, used by eDPQ
Function GetWebPageViaPOST(AURL)
Dim objHttp
Set objHttp = Server.CreateObject("WinHTTP.WinHTTPRequest.5.1")
objHttp.Open "POST", AURL, False
' ignore certificate errors
Const WinHttpRequestOption_SslErrorIgnoreFlags = 4
objHttp.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = &H3300
objHttp.Send
GetWebPageViaPOST = objHttp.ResponseText
Set objHttp = Nothing
End Function
' (SS,16/11/18) strips the HTML tags and replaces < and > with HTML entity
' modified version from https://gist.github.com/gwobcke/1027133
Function StripHTMLTags(AText)
Dim LoRegExp, LResult
Set LoRegExp = New Regexp
LoRegExp.IgnoreCase = True
LoRegExp.Global = True
LoRegExp.Pattern = "<(.|n)+?>"
' replace all HTML tag matches with the empty string
LResult = LoRegExp.Replace(AText, "")
Set LoRegExp = Nothing
' escape the angle brackets too
LResult = EscapeHTMLAngleBrackets(LResult)
StripHTMLTags = LResult
End Function
' (SS,16/11/18) replace all < and > with < and >
Function EscapeHTMLAngleBrackets(AText)
Dim LResult
LResult = Replace(AText, "<", "<")
LResult = Replace(LResult, ">", ">")
EscapeHTMLAngleBrackets = LResult
End Function
' (SS,16/11/18)
' form field values to be fetched using CleanRequestForm which strips HTML tags and converts < and > to HTML entity
' This should now be called instead of Request.Form to fetch a form field.
Function CleanRequestForm(AFieldName)
' CleanRequestForm = StripHTMLTags(Request.Form(AFieldName))
CleanRequestForm = EscapeHTMLAngleBrackets(Request.Form(AFieldName))
End Function
' (SS,20/11/18) same as CleanRequestForm but using Request.QueryString
Function CleanRequestQueryString(AFieldName)
CleanRequestQueryString = EscapeHTMLAngleBrackets(Request.QueryString(AFieldName))
End Function
' (SS,20/11/18) same as CleanRequestForm but similar to Request (only checks Request.QueryString and then Request.Form in that order)
' it doesn't check Cookies and ServerVariables like Request does
Function CleanRequest(AFieldName)
Dim LResult
' check the querystring first, then form
LResult = Request.QueryString(AFieldName)
If IsEmpty(LResult) Then LResult = Request.Form(AFieldName)
If IsEmpty(LResult) Then
CleanRequest = LResult
Else
CleanRequest = EscapeHTMLAngleBrackets(LResult)
End If
End Function
%>