Ken's VBA Code for Various Functions

Return to Home

Return to VBA Code Main Page

AccessAndJetErrorsTable

AdjustDateToOneYearWindow

BreakTextAtX

CalculateAge

ChangeLinkPath

CompactBackendDatabaseFile_Custom

ConcatenateFieldValues

ConvertMonthNameToDateLastDay

CountCharacterOccurrence

CountStringOccurrence

DateForFixedDayOfMonthYear

DateOfSpecificWeekDay

DaysInAMonth

DoubleQDouble

GetLastDayOfMonth

GetMonthName

SingleQDouble

SQLAddBrackets

WhoIsInTheDatabaseLockFile

 

AccessAndJetErrorsTable

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

Return to Top of Page

Return to VBA Code Main Page

Return to Home

 

AdjustDateToOneYearWindow

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 If

Exit Function

Err_AdjustDate:
      MsgBox "Error " & Err.Number & " has occurred: " & Err.Description
      Exit Function

End Function

Return to Top of Page

Return to VBA Code Main Page

Return to Home

 

BreakTextAtX

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 If

End Function

Return to Top of Page

Return to VBA Code Main Page

Return to Home

 

CalculateAge

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

Return to Top of Page

Return to VBA Code Main Page

Return to Home

 

ChangeLinkPath

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

Return to Top of Page

Return to VBA Code Main Page

Return to Home

 

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 Next

strDateTime = 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_Compact

End Function

Return to Top of Page

Return to VBA Code Main Page

Return to Home

 

ConcatenateFieldValues

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

Return to Top of Page

Return to VBA Code Main Page

Return to Home

 

ConvertMonthNameToDateLastDay

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 Date

Dim 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 Function

End Function

Return to Top of Page

Return to VBA Code Main Page

Return to Home

 

CountCharacterOccurrence

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 lngPosition

CountCharacterOccurrence = lngCount

Exit Function
End Function

Return to Top of Page

Return to VBA Code Main Page

Return to Home

 

CountStringOccurrence

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 lngPosition

CountStringOccurrence = lngCount

Exit Function
End Function

Return to Top of Page

Return to VBA Code Main Page

Return to Home

 

DateForFixedDayOfMonthYear

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

Return to Top of Page

Return to VBA Code Main Page

Return to Home

 

DateOfSpecificWeekDay

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

Return to Top of Page

Return to VBA Code Main Page

Return to Home

 

DaysInAMonth

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 Integer

If 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

Return to Top of Page

Return to VBA Code Main Page

Return to Home

 

DoubleQDouble

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

Return to Top of Page

Return to VBA Code Main Page

Return to Home

 

GetLastDayOfMonth

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

Return to Top of Page

Return to VBA Code Main Page

Return to Home

 

GetMonthName

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

Return to Top of Page

Return to VBA Code Main Page

Return to Home

 

SingleQDouble

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

Return to Top of Page

Return to VBA Code Main Page

Return to Home

 

SQLAddBrackets

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 Next

End Function

Return to Top of Page

Return to VBA Code Main Page

Return to Home

 

WhoIsInTheDatabaseLockFile

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

Return to Top of Page

Return to VBA Code Main Page

Return to Home