File: D:/web/hyperflight/! removed on 2026-07-14/doorwaypages/dbfunctions.asp
<%
' ============'
' 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
' 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
Dim oConn, oConnCommon, oRS, oRS2, nRecs, gsADOErrors, gbDatabaseOpen, gbQueryOpen, gbDebugOn, gsErrorMessage, gnDebugLevel
Dim gnOpenDatabaseCount, gnCloseDatabaseCount, gnOpenQueryCount, gnCloseQueryCount, gnExecQueryCount
gbDatabaseOpen = False
gbQueryOpen = False
gbDebugOn = False
gnDebugLevel = 1
gsErrorMessage = ""
gnOpenDatabaseCount = 0
gnCloseDatabaseCount = 0
gnOpenQueryCount = 0
gnCloseQueryCount = 0
gnExecQueryCount = 0
'----------------- 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
If gbDebugOn Then DebugLog("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
If gbDebugOn Then DebugLog("CloseDatabaseCommon called")
oConnCommon.Close
Set oConnCommon = Nothing
End Sub
' (SS,26/5/07) common database version
Sub OpenQueryCommon(ASql)
If gbDebugOn Then DebugLog("OpenQueryCommon called with " & ASql)
IncOpenQueryCount ' (SS,27/5/07)
Set oRS = oConnCommon.Execute(ASql, nRecs, adCmdText)
End Sub
' (SS,26/5/07) common database version
Sub CloseQueryCommon
If gbDebugOn Then DebugLog("CloseQueryCommon called")
IncCloseQueryCount ' (SS,27/5/07)
oRS.Close
Set oRS = Nothing
End Sub
'----------------- 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)
If gbDebugOn Then DebugLog("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 = ""
End If
End Sub
Sub CloseDatabase
gnCloseDatabaseCount = gnCloseDatabaseCount + 1
If gbDebugOn Then DebugLog("CloseDatabase called")
If gbDatabaseOpen Then
oConn.Close
Set oConn = Nothing
gbDatabaseOpen = False
End If
End Sub
' (SS,17/10/06)
Function IsDatabaseOpen
IsDatabaseOpen = gbDatabaseOpen
End Function
Sub OpenQuery(ASql)
If gbQueryOpen Then CloseQuery ' if query already open then close it first '
If gbDebugOn Then DebugLog("OpenQuery called with " & ASql)
IncOpenQueryCount ' (SS,27/5/07)
Set oRS = oConn.Execute(ASql, nRecs, adCmdText)
gbQueryOpen = True
End Sub
Sub CloseQuery
If gbDebugOn Then DebugLog("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
oRS.MoveNext
End Sub
' (SS,10/10/01) '
Sub FirstQueryRecord
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,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)
GetQueryValueNullIfNotFound = Null
On Error Resume Next
GetQueryValueNullIfNotFound = oRS(AFieldName)
End Function
Function GetQueryValue(AFieldName)
If gbDebugOn And gnDebugLevel > 1 Then DebugLog("GetQueryValue called with " & AFieldName)
GetQueryValue = oRS(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
Dim LRecordCount
LRecordCount = 0
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)
FieldsExistInQuery = FieldExists(oRS, AFieldName)
End Function
' (SS,27/5/07) returns true if given field exists in given table
Function FieldExistsInTable(ATableName, AFieldName)
If gbDebugOn Then DebugLog("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)
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) '
Sub OpenQuery2(ASql)
If gbDebugOn Then DebugLog("OpenQuery2 called with " & ASql)
IncOpenQueryCount ' (SS,27/5/07)
Set oRS2 = oConn.Execute(ASql, nRecs, adCmdText)
End Sub
Sub CloseQuery2
If gbDebugOn Then DebugLog("CloseQuery2 called")
IncCloseQueryCount ' (SS,27/5/07)
oRS2.Close
Set oRS2 = Nothing
End Sub
Function EndOfQuery2
EndOfQuery2 = oRS2.Eof
End Function
Sub NextQueryRecord2
oRS2.MoveNext
End Sub
Function GetQueryValue2(AFieldName)
If gbDebugOn And gnDebugLevel > 1 Then DebugLog("GetQueryValue2 called with " & AFieldName)
GetQueryValue2 = oRS2(AFieldName)
End Function
Sub ExecuteQuery(ASql)
' On Error Resume Next '
If gbDebugOn Then DebugLog("ExecuteQuery called with " & ASql)
IncExecQueryCount ' (SS,27/5/07)
oConn.Execute(ASql)
' CheckForADOErrors(oConn)
End Sub
' (SS,14/9/07)
Sub ExecuteQueryCommon(ASql)
' On Error Resume Next '
If gbDebugOn Then DebugLog("ExecuteQueryCommon called with " & ASql)
IncExecQueryCount
oConnCommon.Execute(ASql)
End Sub
' (SS,11/5/01)
Function CheckKeyExists(ATableName, AFieldName, AValue)
Dim LoRS
Set LoRS= oConn.Execute("SELECT * FROM " + ATableName + " WHERE " + AFieldName + "=" + AValue, nRecs, adCmdText)
CheckKeyExists = not LoRS.Eof
LoRS.Close
set LoRS = Nothing
End Function
' (SS,15/5/01) '
Sub OpenTable(ATableName)
If gbDebugOn Then DebugLog("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
If gbDebugOn Then DebugLog("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)
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
' (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 '
Function ReplaceStr(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,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
Function GetLookupCombo(ATableName, AFieldName, AOrderField, ADefaultValue, AShowBlank, ASelectName, AExtras, AWhereClause)
Dim s, strFieldValue, LSelectName, LShowBlank, LBlankValue
LSelectName = AFieldName
If ASelectName <> "" Then LSelectName = ASelectName
s = "<select name=""" + LSelectName + """ class=""form""" + AExtras + ">"
' (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)
' (SS,5/10/04) replaced "+ strFieldValue +" with "& strFieldValue &"
s = s + "<option value=""" & strFieldValue & """"
' (SS,5/10/04) added Trim to following to ensure values are converted to strings for comparison '
If Trim(strFieldValue) = Trim(ADefaultValue) Then s = s + " selected"
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 + """ class=""form"">"
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 + """ class=""form"">"
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,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/070 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
s = "<select name=""" + ASelectName + """ class=""form"">"
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,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
' 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,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)
Function CleanSQLStr(AValue)
Dim LNewValue
If IsNull(AValue) Then AValue = "" ' (SS,27/6/05) added this to prevent invalid use of null error '
LNewValue = AValue
LNewValue = Replace(LNewValue, "\", "\\")
LNewValue = Replace(LNewValue, "'", "\'")
LNewValue = Replace(LNewValue, """", "\""")
CleanSQLStr = LNewValue
End Function
' (SS,26/6/04) '
' converts newlines to breaks for HTML '
Function ConvertNewlinesToHTML(AString)
ConvertNewlinesToHTML = ReplaceStr(AString, Chr(13) & Chr(10), "<br>")
End Function
' (SS,5/7/07) encode string to HTML, e.g. characters like " become "e; etc
' it actually calls Server.HTMLEncode
Function HTMLEncode(AValue)
HTMLEncode = Server.HTMLEncode(AValue)
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
' 6/10/03 runs a query and returns the value from given field, null is returned if no records found
Function GetValueFromQuery(AFieldName, ASQL)
If gbDebugOn Then DebugLog("GetValueFromQuery called with " & AFieldName & ", " & ASQL)
Dim LoRS
Set LoRS = oConn.Execute(ASQL, nRecs, adCmdText)
If LoRS.Eof Then
GetValueFromQuery = Null
Else
GetValueFromQuery = LoRS(AFieldName)
End If
LoRS.Close
Set LoRS = Nothing
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'
Function GetSetting(AGroupName, AFieldName)
If gbDebugOn Then DebugLog("GetSetting called with " & AGroupName & ", " & AFieldName)
Dim LoRS
Set LoRS = oConn.Execute("SELECT FieldValue FROM Settings WHERE GroupName = '" & AGroupName & "' AND FieldName = '" & AFieldName & "'", nRecs, adCmdText)
If LoRS.Eof Then
GetSetting = Null
Else
GetSetting = LoRS("FieldValue")
End If
LoRS.Close
Set LoRS = Nothing
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'
Sub SetSetting(AGroupName, AFieldName, AFieldValue)
If gbDebugOn Then DebugLog("SetSetting called with " & AGroupName & ", " & AFieldName)
oConn.Execute("UPDATE settings SET FieldValue = '" & CleanSQLStr(AFieldValue) & "' WHERE GroupName = '" & AGroupName & "' AND FieldName = '" & AFieldName & "'")
End Sub
' (SS,14/11/07) add new setting
Sub AddSetting(AGroupName, AFieldName, AFieldValue)
If gbDebugOn Then DebugLog("AddSetting called with " & AGroupName & ", " & AFieldName)
oConn.Execute("INSERT INTO settings SET GroupName = '" & AGroupName & "', FieldName = '" & AFieldName & "', FieldValue = '" & CleanSQLStr(AFieldValue) & "'")
End Sub
' shows the debug message, perhaps in the future add it to a log '
Sub DebugLog(ADebugMessage)
Response.Write "*** " & ADebugMessage & " ***<br><br>"
End Sub
' (SS,13/8/04)
Sub DebugOn
gbDebugOn = True
End Sub
' (SS,13/8/04)
Sub DebugOff
gbDebugOn = False
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,26/5/07)
Sub ShowOpenDatabaseCount
DebugLog("No of Database Opens: " & gnOpenDatabaseCount)
DebugLog("No of Database Closes: " & gnCloseDatabaseCount)
DebugLog("No of Query Opens: " & gnOpenQueryCount)
DebugLog("No of Query Closes: " & gnCloseQueryCount)
DebugLog("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)
If 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)
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)
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 ""
Function TrimAll(AString)
Dim LString, LLen, LStart, LEnd, i
LLen = Len(AString)
LString = NB(AString)
If LString = "" Then
TrimAll = ""
Exit Function
End If
For i = 1 To LLen
If Asc(Mid(LString, i, 1)) > 32 Then
Exit For
End if
Next
LStart = i
LEnd = LLen
For i = LLen To 1 Step -1
If Asc(Mid(LString, i, 1)) > 32 Then
Exit For
End if
Next
LEnd = i
If LEnd < LStart Then
TrimAll = ""
Else
TrimAll = 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,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,21/10/08) splits a UK postcode into its 4 parts, and returns true if it's valid
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
If ASuffix <> "" And 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
If IsCharNumeric(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
%>