Ken's VBA Code for Various Functions
This function creates a table, and then inserts the ACCESS and Jet (database engine) error codes, with error descriptions, into the table.
Public Function AccessAndJetErrorsTable() As Boolean
' Code adapted from an example in ACCESS 97 Help File
Dim dbs As DAO.Database
Dim fld As DAO.Field
Dim rst As DAO.Recordset
Dim tdf As DAO.TableDef
Dim lngCode As Long
Dim strAccessErr As String
Const conAppObjectError = "Application-defined or object-defined error"
On Error GoTo Error_AccessAndJetErrorsTable
' Create Errors table with ErrorNumber and ErrorDescription fields
Set dbs = CurrentDb
Set tdf = dbs.CreateTableDef("AccessAndJetErrors")
Set fld = tdf.CreateField("ErrorCode", dbLong)
tdf.Fields.Append fld
Set fld = tdf.CreateField("ErrorString", dbMemo)
tdf.Fields.Append fld
dbs.TableDefs.Append tdf
' Open recordset on Errors table
Set rst = dbs.OpenRecordset("AccessAndJetErrors")
' Loop through error codes (numbers 0 through 3500)
For lngCode = 0 To 3500
On Error Resume Next
' Raise each error
strAccessErr = AccessError(lngCode)
DoCmd.Hourglass True
' Skip error numbers without associated strings
If strAccessErr <> "" Then
' Skip codes that generate application or object-defined errors
If strAccessErr <> conAppObjectError Then
' Add each error code and string to Errors table
rst.AddNew
rst!ErrorCode = lngCode
' Append string to memo field
rst!ErrorString.AppendChunk strAccessErr
rst.Update
End If
End If
Next lngCode
' Close recordset
rst.Close
Set rst = Nothing
DoCmd.Hourglass False
RefreshDatabaseWindow
MsgBox "Access and Jet errors table created."
AccessAndJetErrorsTable = True
Exit_AccessAndJetErrorsTable:
Exit Function
Error_AccessAndJetErrorsTable:
MsgBox Err & ": " & Err.Description
AccessAndJetErrorsTable = False
Resume Exit_AccessAndJetErrorsTable
End Function
This function adjusts the provided date to be the same month and date, but with the year corresponding to its next occurrence. For example, if today's date is January 22, 2004, and the original date that is passed to the function is January 1, 2000, the function returns the date of January 1, 2005 (the next date on which this recurrence will occur). This function is useful for identifying when recurring, annual dates that can "expire" or "come due" (e.g., a rental payment date, a membership renewal date, a contract renewal date, etc.) will occur next.
Public Function AdjustDateToOneYearWindow(datOrigDate As Variant) As Date
Dim intMonth As Integer, intDay As Integer
Dim intCYear As Integer, intNYear As Integer
On Error GoTo Err_AdjustDate
' Set default date for function in case the argument provided is Null
AdjustDateToOneYearWindow = #1/1/1900#
If Len(datOrigDate & "") > 0 Then
If IsDate(datOrigDate) = True Then
intMonth = Month(datOrigRentDueDate)
intDay = Day(datOrigRentDueDate)
intCYear = Year(Date)
AdjustDateToOneYearWindow = DateSerial(Year(Date) - _
(intMonth < Month(Date) Or (intMonth = Month(Date) _
And intDay < Day(Date))), intMonth, intDay)
End If
End IfExit Function
Err_AdjustDate:
MsgBox "Error " & Err.Number & " has occurred: " & Err.Description
Exit Function
End Function
This function inserts "line breaks" (the carriage return character followed by the line feed character) in the text that is provided to the function, based on the character that identifies when one line should end and the next line should begin (the "strBreakCharacter" value). The function then returns the modified text string.
Public Function BreakTextAtX(varOriginal As Variant, _
Optional strBreakCharacter As String = " ", _
Optional lngMaxLength As Long = 72) As Variant
' Code written by Ken Snell -- 15 November 2008
' strOriginal is the original text string
' strBreakCharacter is the character that is used to break the
' text into separate lines (e.g., a blank space); if no
' character is provided to the function, it uses a blank
' space as the value
' lngMaxLength is the maximum length for each separate line;
' if no length is provided ot the function, it uses 72
' as the maximum length
Dim strNewString As String, strWorking As String, strPart As String
Dim strOriginalNoCrLf As String
Dim lngPosition As Long, lngHold As Long, lngLength As Long
Dim lngWorkLength As Long
lngLength = Len(varOriginal & "")
If lngLength > 0 Then
strOriginalNoCrLf = Replace(Replace(CStr(varOriginal), vbCr, ""), _
vbLf, "")
strNewString = ""
lngPosition = 1
Do While lngPosition <= lngLength
strWorking = Mid(strOriginalNoCrLf, lngPosition, lngMaxLength)
lngWorkLength = Len(strWorking)
If lngWorkLength < lngMaxLength Then
If Len(strNewString) > 0 And Len(strWorking) > 0 Then _
strNewString = strNewString & vbCrLf
strNewString = strNewString & strWorking
Exit Do
Else
lngHold = InStrRev(strWorking, strBreakCharacter)
If lngHold = 0 Then lngHold = lngWorkLength
If Len(strNewString) > 0 Then _
strNewString = strNewString & vbCrLf
strNewString = strNewString & Left(strWorking, lngHold)
lngPosition = lngPosition + lngHold
End If
Loop
BreakTextAtX = strNewString
Else
If IsNull(varOriginal) = True Then
BreakTextAtX = varOriginal
Else
BreakTextAtX = ""
End If
End IfEnd Function
This function is based a function named "CalculateAge" that was originally written by Arvin Meyer (ACCESS MVP). It is used to calculate an age in years, based on either today's date or on another date that is provided to the function.
Public Function CalculateAge(DOB As Variant, Optional vDate As Variant) As Variant
' Author: Arvin Meyer, 5/15/97 (modified by Ken Snell, 9/8/2003)
' Notes: Age calculated as of vDate, or as of today if vDate is missing
' Arguments:
' DOB (Variant)
' vDate (Optional) (Variant)
' Returns:
' Age in years, for a person whose Date Of Birth is DOB
If IsDate(vDate) = False Then vDate = Date
If IsDate(DOB) = True Then
CalculateAge = DateDiff("yyyy", DOB, vDate) + _
(DateSerial(Year(vDate), Month(DOB), Day(DOB)) > vDate)
Else
CalculateAge = Null
End If
End Function
This function changes the path for linked tables to a new path, which must be provided to the function. The function does this by dropping the linked table, and then relinking to that same table in the database specified in the new path.
Public Function ChangeLinkPath(strNewPath As String) As String
Dim dbs As DAO.Database
Dim strTblName As String
Dim colTbl As Collection
Dim intTbl As Integer
If strNewPath <> "" And Dir(strNewPath) <> "" Then
Set colTbl = New Collection
Set dbs = CurrentDb
For intTbl = dbs.TableDefs.Count - 1 To 0 Step -1
If dbs.TableDefs(intTbl).Connect <> "" And _
Not dbs.TableDefs(intTbl).Connect Like "*" & strNewPath Then
colTbl.Add dbs.TableDefs(intTbl).Name
dbs.TableDefs.Delete dbs.TableDefs(intTbl).Name
End If
Next intTbl
For intTbl = colTbl.Count To 1 Step -1
strTblName = colTbl(intTbl)
DoCmd.TransferDatabase acLink, "Microsoft Access", _
strNewPath, acTable, strTblName, strTblName
Debug.Print "connection made to '" & strTblName & "'"
Next intTbl
Set dbs = Nothing
Set colTbl = Nothing
Debug.Print "DONE!"
ChangeLinkPath = "DONE!"
Else
Debug.Print "New path not provided. No changes made!"
ChangeLinkPath = "New path not provided. No changes made!"End If
Exit Function
End Function
CompactBackendDatabaseFile_Custom
This function compacts an ACCESS database file. If the value provided to the function for blnKeepBackup is True, a backup copy of the original, uncompacted database is made; otherwise, no backup file is made. Although its original design was for compacting a backend database file, it can be used for any ACCESS database file that is not currently being used by anyone. The function returns one of four integer values: -1 if the ACCESS database file is in use (no compaction can be done); 0 if the compaction was done successfully; 1 if the ACCESS database cannot be found (no compaction was done); or 2 if an error occurred during the compaction (no compaction was done).
Public Function CompactBackendDatabaseFile_Custom(strPathFilename_OriginalBEDB As String, _
strPathFilename_TemporaryBEDB As String, blnKeepBackup As Boolean) As Integer' strPathFilename_OriginalBEDB is the path and filename of the
' ACCESS file that you want to compact
' strPathFilename_TemporaryBEDB is the path and filename that
' you want the function to use for the temporary copy of
' the ACCESS file that the function will create as part
' of how the function does the compacting (NOTE: if you
' want to keep a copy of the backend file as a backup
' (archive) copy, the function will add a date/time
' stamp to the end of the filename)
' blnKeepBackup tells the function if you want to have it
' keep a copy of the ACCESS file as a backup copy or not
' (value of 0 or False tells the function to not keep
' a copy of the compacted file as a backup copy; -1 or
' True tells the function to keep a copy of the compacted
' file as a backup copy)' The function returns an INTEGER value:
' -1 If a "lock file" (".ldb") exists for the original file, indicating that the
' file is in use (no compaction was done)
' 0 If no errors were encountered during the compaction process
' 1 If the original file cannot be found (no compaction done)
' 2 If an error was encountered during the compaction (no compaction done)
Dim intLocation As Integer
Dim xlngLooping As Long
Dim strTempBEDB As String, strTemp As String
Dim strDrive As String, strDateTime As String
Const strLockFileExtension As String = "ldb"
On Error Resume NextstrDateTime = Format(Now, "mmmddyyyyhhnnssAmPm")
strTempBEDB = strPathFilename_TemporaryBEDB
intLocation = InStrRev(strTempBEDB, "\")
strTempBEDB = Left(strTempBEDB, intLocation) & strDateTime & _
Mid(strTempBEDB, intLocation + 1)
If Dir(Left(strPathFilename_OriginalBEDB, Len(strPathFilename_OriginalBEDB) - 3) & _
strLockFileExtension) = "" Then
On Error GoTo Err_Compact_1
Name strPathFilename_OriginalBEDB As strTempBEDB
DoEvents
On Error GoTo Err_Compact_2
DBEngine.CompactDatabase strTempBEDB, strPathFilename_OriginalBEDB
DoEvents
Do Until Dir(strPathFilename_OriginalBEDB) <> ""
On Error Resume Next
For xlngLooping = 0 To 25
DoEvents
Next xlngLooping
Loop
On Error Resume Next
If blnKeepBackup = False Then _
Kill strTempBEDB
CompactBackendDatabaseFile_Custom = 0
Else
CompactBackendDatabaseFile_Custom = -1
End If
Exit_Compact:
Exit Function
Err_Compact_1:
On Error Resume Next
MsgBox "The original database file cannot be found at this location:" & _
vbCrLf & " " & strPathFilename_OriginalBEDB & vbCrLf & _
"The file cannot be compacted.", vbExclamation, "Cannot Find The File!"
CompactBackendDatabaseFile_Custom = 1
Resume Exit_Compact
Err_Compact_2:
On Error Resume Next
Kill strPathFilename_OriginalBEDB
FileCopy strTempBEDB, strPathFilename_OriginalBEDB
MsgBox "An error occurred during the compacting operation of the file!" & _
vbCrLf & _
"The file cannot be compacted.", vbExclamation, "File Compaction Error!"
CompactBackendDatabaseFile_Custom = 2
Resume Exit_CompactEnd Function
This function is based a function named "Concatenate" that was originally written by Duane Hookom (ACCESS MVP); he has a sample database that contains the function. It is used to create a concatenated string from a single field's values from all the records desired to be included in the concatenated string. The records to be included, plus the field to be used for creating the concatenated string, are specified by an SQL statement that is passed to the function. The SQL statement passed to the function must return only one field in order for this function to work correctly. The values in the concatenated string are separated by a character string that is provided to the function as a delimiter string (if no delimiter is provided, the function uses a comma followed by a space).
Public Function ConcatenateFieldValues(pstrSQL As String, _
Optional pstrDelim As String = ", ") As String
' Created by Duane Hookom, 2003
' this code may be included in any application/mdb providing
' this statement is left intact
' example
' tblFamily with FamID as numeric primary key
' tblFamMem with FamID, FirstName, DOB,...
' return a comma separated list of FirstNames for a FamID
' John, Mary, Susan
' in a Query
' SELECT FamID,
' ConcatenateFieldValues("SELECT FirstName
' FROM tblFamMem WHERE FamID =" & [FamID]) AS FirstNames
' FROM tblFamily;
'---------------------
' Modified by Ken Snell 29 October 2005
' *** THIS FUNCTION BUILDS A CONCATENATED STRING THAT CONTAINS
' *** THE VALUES OF ONE FIELD FOR EACH RECORD IN A TABLE OR
' *** QUERY, WITH EACH VALUE SEPARATED BY A SPECIFIED DELIMITER.
Dim strConcat As String
'======For ADO comment next 2 lines and =======
'====== uncomment out ADO lines below =======
Dim db As DAO.Database
Dim rs As DAO.Recordset
On Error Resume Next
strConcat = ""
'======For ADO comment out next 2 DAO lines and =======
'====== uncomment ADO lines below =======
Set db = CurrentDb
Set rs = db.OpenRecordset(pstrSQL)
'======For ADO uncomment next two lines and =====
'====== comment out DAO lines above and below ======
' Dim rs As New ADODB.Recordset
' rs.Open pstrSQL, CurrentProject.Connection, _
' adOpenKeyset, adLockOptimistic
With rs
If Not .EOF Then
.MoveFirst
Do While Not .EOF
strConcat = strConcat & .Fields(0) & pstrDelim
.MoveNext
Loop
End If
.Close
End With
Set rs = Nothing
'====== Comment next 2 lines for ADO ========
db.Close
Set db = Nothing
If Len(strConcat) > 0 Then strConcat = _
Left(strConcat, Len(strConcat) - Len(pstrDelim))
ConcatenateFieldValues = strConcat
Exit Function
End Function
This function uses the name of a month (in either "mmmm" or "mmm" format) that is provided to the function in order to return a date that corresponds to the last day of that month in the current year. For example, if "January" (or "Jan") is provided to the function, the function returns the date January 31, 2009 (assuming that the current year is 2009) as a Date datatype value. The function returns a value of 0 if the function does not recognize the month name that is provided to it. NOTE: This function uses two additional functions -- GetLastDayOfMonth and GetMonthName -- both of which are posted on this web page. You will need to include those functions in your database in order to use this function.
Public Function ConvertMonthNameToDateLastDay( _
ByVal strMonthNameString As String) As DateDim intLoop As Integer
If Len(strMonthNameString) > 2 Then
For intLoop = 1 To 12
If UCase(strMonthNameString) = UCase(Left(GetMonthName(intLoop, 1), _
Len(strMonthNameString))) Then Exit For
Next intLoop
If intLoop < 13 Then
ConvertMonthNameToDateLastDay = DateSerial(Year(Date), intLoop, _
GetLastDayOfMonth(strMonthNameString, Year(Date)))
Else
GoTo BadMonthName_Label
End If
Else
GoTo BadMonthName_Label
End If
Exit Function
BadMonthName_Label:
ConvertMonthNameToDateLastDay = "0"
Exit FunctionEnd Function
This function counts the number of times that a single character occurs within the string that is passed to the function, and returns the count. The search performed within the function can be case-sensitive or case-insensitive, depending upon the value of the blnCase parameter that is passed to the function (True for case-sensitive search, False for case-insensitive search). If the blnCase parameter is not supplied to the function, the function will perform a case-sensitive search..
Public Function CountCharacterOccurrence(ByVal strString As String, ByVal strChar As String, _
Optional ByVal blnCase As Boolean = True) As Long
Dim lngPosition As Long, lngCount As Long
lngCount = 0
' Truncate strChar in case it is longer than one character
strChar = Left(strChar, 1)
If blnCase = False Then
' Search is to be case-insensitive, so convert both the single character
' and the string being searched to upper case characters
strString = UCase(strString)
strChar = UCase(strChar)
End If
For lngPosition = 1 To Len(strString)
' If the desired character is found, increment the counter
If Asc(Mid(strString, lngPosition, 1)) = Asc(strChar) Then _
lngCount = lngCount + 1
Next lngPositionCountCharacterOccurrence = lngCount
Exit Function
End Function
This function counts the number of times that a character string occurs within the string that is passed to the function, and returns the count. The search performed within the function can be case-sensitive or case-insensitive, depending upon the value of the blnCase parameter that is passed to the function (True for case-sensitive search, False for case-insensitive search). If the blnCase parameter is not supplied to the function, the function will perform a case-sensitive search.
Public Function CountStringOccurrence(ByVal strString As String, _
ByVal strCharString As String, Optional ByVal blnCase As Boolean = True) As Long
Dim lngPosition As Long, lngLen As Long, lngCount As Long
lngCount = 0
lngLen = Len(strCharString)
If blnCase = False Then
' Search is to be case-insensitive, so convert both the character string
' and the string being searched to upper case characters
strString = UCase(strString)
strCharString = UCase(strCharString)
End If
For lngPosition = 1 To Len(strString) - lngLen + 1
' If the desired character string is found, increment the counter
If StrComp(Mid(strString, lngPosition, lngLen), strCharString, vbBinaryCompare) = 0 _
Then lngCount = lngCount + 1
Next lngPositionCountStringOccurrence = lngCount
Exit Function
End Function
This function returns the actual date for a "fixed" day and month within any year. Parameters for the function are the year for the desired date, the number of the month (1 = January, 2 = February, etc.) for the desired date, the number of the day of the week (1 = Sunday, 2 = Monday, etc.) for the desired date, and the ordinal value for the recurrence of the day of the week for the desired date. For example, if you want to know the date of the second Wednesday of May in 2005, the function call would be DateForFixedDayOfMonthYear(2005, 5, 4, 2), and the function will return the date of May 11, 2005. This function is useful for identifying dates for meetings or events that occur on specific schedules (for example, the first Tuesday of every month).
Public Function DateForFixedDayOfMonthYear(Day_Year As Integer, _
Day_Month As Integer, Day_Day As Integer, Day_WeekNum As Integer) As Date
' Day_Year is the actual year for the desired date
' Day_Month is the actual month for the desired date
' Day_Day is the number of the weekday (1 = Sunday, etc. to 7 = Saturday)
' Day_WeekNum is the ordinal value for the desired date (e.g., 1 = first, 2 = second)
'
' So, if you want the 2nd Wednesday of May 2005:
' MyDate = DateForFixedDayOfMonthYear(2005, 5, 4, 2)
DateForFixedDayOfMonthYear = DateSerial(Day_Year, Day_Month, _
8 - DatePart("w", DateSerial(Day_Year, Day_Month, 1), _
1 + Day_Day Mod 7) + (Day_WeekNum - 1) * 7)
Exit Function
End Function
This function uses the number of a weekday (1 = Sunday, 2 = Monday, etc.) that is provided to the function in order to return a date that corresponds to that weekday within the same calendar week (Sunday through Saturday) as the "original date" that is provided to the function. For example, if you want to know the date of the Sunday in the same calendar week as the date of June 10, 2009 (which is the Wednesday in that calendar week), the call to the function would be DateOfSpecificWeekDay(#6/10/2009#, 1), and the function will return the date of June 7, 2009.
Public Function DateOfSpecificWeekDay(ByVal OriginalDate As Date, _
ByVal intWeekDay As Integer) As Date
DateOfSpecificWeekDay = DateAdd("d", -DatePart("w", OriginalDate, 1) _
+ intWeekDay, OriginalDate)
Exit Function
End Function
This function returns the number of days that are in a specific month in a specific year, where the month is identified by the number of the month (1 = January, 2 = February, etc.).
Public Function DaysInAMonth(ByVal intMonthNumber As Integer, _
ByVal intYearValue As Integer) As IntegerIf intMonthNumber < 0 Or intMonthNumber > 12 Then
DaysInAMonth = 0
Else
If intMonthNumber = 12 Then intMonthNumber = 0
DaysInAMonth = Day(DateSerial(intYearValue, intMonthNumber + 1, 0))
End If
Exit Function
End Function
This function replaces each occurrence of the " character in a string with two " characters. This is helpful when using the string in a "Like" comparison (pattern-search comparison) in a query (e.g., "WHERE FieldName Like """ & SearchString & """").
Public Function DoubleQDouble(ByVal xstrReplaceStringValue As String) As String
DoubleQDouble = Replace(xstrReplaceStringValue, """", """""", 1, -1, vbTextCompare)
End Function
This function uses the name of a month (in either "mmmm" or "mmm" format) or the number of a month (1 through 12) that is provided to the function in order to return a number that corresponds to the last day of that month in the current year. For example, if "January" (or "Jan" or 1) is provided to the function, the function returns a value of 31 (assuming that the current year is 2009) as a Integer datatype value. The function returns a value of -1 if an integer value less than 1 is provided to the function; a value of -10 if an integer value greater than 12 is provided to the function; or a value of -100 if the function cannot recognize the month name or the month number that is provided to the function. NOTE: This function uses one additional function -- GetMonthName -- which is posted on this web page. You will need to include that function in your database in order to use this function.
Public Function GetLastDayOfMonth(ByVal varMonth As Variant, ByVal intYear As Integer) _
As Integer
' This function uses either a month number (an integer value between 1 TO 12)
' or a month name (in either "mmmm" [long name] or "mmm" [short name]) to calculate the
' the last day of that monght in the current year.
' This number is returned as an integer value by the function.
'
' If the month number provided to the function is less than 1, the function returns a
' value of -1.
' If the month number provided to the function is greater than 12, the function returns
' a value of -10.
' If the month name is not recognizable, the function returns a value of -100.
Dim intVarType As Integer, intDay As Integer, intLoop As Integer
Dim lngValue As Long
Const lngUnknown As Long = -99999
Const intLow As Integer = -1
Const intHigh As Integer = -10
Const intUnknown As Integer = -100
intVarType = VarType(varMonth)
If intVarType = vbInteger Or intVarType = vbLong Then
lngValue = varMonth
ElseIf intVarType = vbString Then
If Len(varMonth) > 2 Then
For intLoop = 1 To 12
If UCase(varMonth) = UCase(Left(GetMonthName(intLoop), Len(varMonth))) _
Then Exit For
Next intLoop
If intLoop < 13 Then
lngValue = intLoop
Else
lngValue = lngUnknown
End If
Else
lngValue = lngUnknown
End If
ElseIf intVarType = vbSingle Or intVarType = vbDouble Or intVarType = vbDecimal Then
lngValue = CLng(varMonth)
Else
lngValue = lngUnknown
End If
If lngValue = -99999 Then
GetLastDayOfMonth = intUnknown
ElseIf lngValue < 1 Then
GetLastDayOfMonth = intLow
ElseIf lngValue > 12 Then
GetLastDayOfMonth = intHigh
Else
GetLastDayOfMonth = Day(DateSerial(intYear, lngValue + 1, 0))
End If
Exit Function
End Function
This function uses a month number (1 through 12) that is provided to the function in order to return the name of the month that corresponds to that month number. The format of the month name can be "mmmm" (e.g., "January") or "mmm" (e.g., "Jan"), depending upon the value of the intMonthFormat parameter (a value of 1 means return the "mmmm" format, a value of 2 means return the "mmm" format). The function returns a value of "Error_L" if an integer value less than 1 is provided to the function; or a value of "Error_H" if an integer value greater than 12 is provided to the function.
Public Function GetMonthName(ByVal intMonth As Integer, Optional ByVal _
intMonthFormat As Integer = 2) As String
' This function uses a month number (1 through 12) in order to return
' the name of the month that corresponds to that month number. The format
' of the month name can be "mmmm" (e.g., "January") or "mmm" (e.g., "Jan"),
' depending upon the value of the intMonthFormat parameter. If no value
' or an invalid value is provided for the intMonthFormat parameter,
' the function will return the month name in the "mmm" format.
'
' intMonthFormat can be one of these two numbers:
' 1 means return the "mmmm" format
' 2 means return the "mmm" format
'
' The function returns a value of "Error_L" if an integer value less than 1
' is provided to the function; or a value of "Error_H" if an integer value
' greater than 12 is provided to the function.
If intMonth < 1 Then
GetMonthName = "Error_L"
ElseIf intMonth > 12 Then
GetMonthName = "Error_H"
Else
If intMonthFormat < 1 Or intMonthFormat > 2 Then intMonthFormat = 2
GetMonthName = Format(DateSerial(Year(Date), intMonth, 1), _
Choose(intMonthFormat, "mmmm", "mmm"))
End If
Exit Function
End Function
This function replaces each occurrence of the ' character in a string with two ' characters. This is helpful when using the string in a "Like" comparison (pattern-search comparison) in a query (e.g., "WHERE FieldName Like '" & SearchString & "'").
Public Function SingleQDouble(ByVal xstrReplaceStringValue As String) As String
SingleQDouble = Replace(xstrReplaceStringValue, "'", "''", 1, -1, vbTextCompare)
End Function
This function surrounds each occurrence of the [, *, #, and ? characters in a string with a pair of left and right square brackets ( [ ] ). This is helpful when using the string in a "Like" comparison (pattern-search comparison) in a query (e.g., "WHERE FieldName Like '" & SearchString & "'") because these are special characters for a pattern-search process. This function should not be used when doing a "direct" comparison in a query (e.g., "WHERE FieldName = '" & SearchString & "'").
Public Function SQLAddBrackets(ByVal varReplaceStringValue As Variant) As String
' *** This function surrounds "[", "*", "#", AND "?" characters with [ and ] characters
' *** in a text string. Its use is for text strings that are used as parameters in various
' *** queries' "WHERE" clauses when "LIKE" is used instead of "=".
' *** This function should be used when "LIKE" is used to match a text string.' *** This function is not to be used when "=", "<>", or another direct-comparison
' *** operator is used to match a text string.
On Error GoTo Error_Function
xstrReplaceStringValue = Replace(Nz(varReplaceStringValue, ""), _
"[", "[[]", 1, -1, vbTextCompare)
xstrReplaceStringValue = Replace(Nz(varReplaceStringValue, ""), _
"*", "[*]", 1, -1, vbTextCompare)
xstrReplaceStringValue = Replace(Nz(varReplaceStringValue, ""), _
"#", "[#]", 1, -1, vbTextCompare)
xstrReplaceStringValue = Replace(Nz(varReplaceStringValue, ""), _
"?", "[?]", 1, -1, vbTextCompare)
SQLAddBrackets = varReplaceStringValue
Exit_Function:
Err.Clear
Exit Function
Error_Function:
SQLAddBrackets = xstrReplaceStringValue
Resume NextEnd Function
This function reads the ".ldb" (locking database) file associated with the ACCESS database in which this function is run, and returns a list of the users who are listed in that ".ldb" file.
Public Function WhoIsInTheDatabaseLockFile() As String
' OUTPUTS A LIST OF USERS IN THE DATABASE:
' 1. COMPUTER NAME ("COMPUTER NAME")
' 2. LOGON NAME ("LOGIN_NAME")
' 3. WHETHER USER IS STILL CONNECTED TO THE DB (USER ID
' REMAINS IN .LDB FILE UNTIL LAST USER EXITS OR
' UNTIL THE SLOT IS CLAIMED BY ANOTHER USER)
' ("CONNECTED")
' 4. WHETHER USER'S CONNECTION TERMINATED UNDER NORMAL
' CIRCUMSTANCES ("SUSPECT_STATE")
' *** ADAPTED FROM MICROSOFT KNOWLEDGE BASE ARTICLE 285822
Dim cn As New ADODB.Connection
Dim dbs As DAO.Database
Dim xlngLoop As Long
Dim rs As New ADODB.Recordset
Dim strNewDataSource As String, strCNString As String, xTT As String
Dim strCurrConnectString As String, xstrUserArray As String
Const strDummyTableName As String = "tbl__DummyTable_KeepRecordsetOpen"
Const strDatabaseString As String = "DATABASE="
Const strDataSourceText As String = "Data Source="
On Error GoTo Err_Msg
xstrUserArray = ""
strCurrConnectString = CurrentProject.Connection
strCNString = Mid(strCurrConnectString, InStr(strCurrConnectString, _
strDataSourceText) + Len(strDataSourceText))
strCNString = Left(strCNString, InStr(strCNString, ";") - 1)
Set dbs = CurrentDb
strNewDataSource = dbs.TableDefs(strDummyTableName).Connect
strNewDataSource = Mid(strNewDataSource, InStr(strNewDataSource, _
strDatabaseString) + Len(strDatabaseString))
Debug.Print "File containing the data tables: " & strNewDataSource
cn.ConnectionString = Replace(strCurrConnectString, strCNString, _
strNewDataSource, 1, 1, vbTextCompare)
cn.Open
' The user roster is exposed as a provider-specific schema rowset
' in the Jet 4.0 OLE DB provider. You have to use a GUID to
' reference the schema, as provider-specific schemas are not
' listed in ADO's type library for schema rowsets
Set rs = cn.OpenSchema(adSchemaProviderSpecific, _
, "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
'Output the list of all users in the designated database
Debug.Print rs.Fields(0).Name, "", rs.Fields(1).Name, _
"", rs.Fields(2).Name, rs.Fields(3).Name
While Not rs.EOF
Debug.Print rs.Fields(0), rs.Fields(1), rs.Fields(2), rs.Fields(3)
For xlngLoop = 0 To 3
xTT = Trim(Nz(rs.Fields(xlngLoop), ""))
If Len(xTT) > 1 Then
If Right(xTT, 1) = Chr(0) Then xTT = Left(xTT, Len(xTT) - 1)
End If
xstrUserArray = xstrUserArray & xTT & strPipeDelimiterChar
Next xlngLoop
rs.MoveNext
Wend
If Len(xstrUserArray) > 0 Then xstrUserArray = Left(xstrUserArray, _
Len(xstrUserArray) - 1)
WhoIsInTheDatabaseLockFile = xstrUserArray
Exit_Function:
On Error Resume Next
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
dbs.Close
Set dbs = Nothing
Exit Function
Err_Msg:
Debug.Print "Error occurred. Error number " & Err.Number & ": " & Err.Description
Resume Exit_Function
End Function