Useful Functions

VBA functions by Adrian Price

Paste these functions into a module called modFunctions so to be accessible to all parts of a program.

Set Property

Sets an Access database application property

Sub apSetProperty(strName As String, ByVal nDataType As DataTypeEnum, varValue)' Sets the value of the Database property. Creates if it doesn't exist
 Dim db As DAO.Database 'Requires ref: Microsoft DAO 3.6 Object Library, DAO360.DLL Dim prp As DAO.Property Dim nErr As Long
On Error GoTo ErrorHandler
 'Some data types not liked If nDataType = dbDecimal Then nDataType = dbCurrency
 Set db = CurrentDb db.Properties(strName) = varValue 'temp = dbs.Properties(strName)
ExitSub:
On Error GoTo 0
 db.Close Set prp = Nothing Set db = Nothing Exit Sub
ErrorHandler: nErr = Err' temp = Err.Description
'On Error GoTo 0
 Select Case nErr
 Case 3265 'No such property - create db.Properties.Delete strName Set prp = db.CreateProperty(strName, nDataType, varValue) db.Properties.Append prp Resume Next
 Case 3270 'Property not found - create it
 '14 Mar 02: Err 13, Type mismatch due to missing DAO. in Dim prp... Set prp = db.CreateProperty(strName, nDataType, varValue) db.Properties.Append prp Resume Next
 Case Else apMsgBox "Error: " & Err & ": " & Err.Description, vbCritical, _ "Error in apSetProperty()" Resume ExitSub
 End Select
End Sub

Get the Names of Forms and Sub-Forms and their Sub-Forms

This routine is reiterative. You can step though the code after placing the cursor in the test routine at the end of the code.

'List ALL sub forms in the parent - posted to DevHut March 2020Private Function ListSubFrms1(frm As Access.Form) As String'Thanks to Daniel Pineault at https://www.devhut.net/2014/03/13/list-subforms-within-another-form-ms-access-vba/'11 Mar 2020: Made re-iterative to check sub subforms
 Dim sCtrl As String, sFormsList As String Dim ctl As Access.Control Dim sf As Access.Form
'On Error GoTo Error_Handler
 'sFrm = "frmSettings" 'DoCmd.OpenForm sFrm, acDesign 'Set frm = Forms(sFrm).Form If frm Is Nothing Then GoTo Error_Handler_Exit temp = frm.Name For Each ctl In frm.Controls Select Case ctl.Properties("ControlType") Case acSubform ', acListBox ' ctl.Name 'Will return the given name of the control, not necessarily the actual object name ' ctl.Properties("SourceObject") 'Will return the object name If ctl.Properties("SourceObject") = "" Then 'Never gets here Debug.Print ctl.Name Else sCtrl = ctl.Properties("SourceObject") 'Debug.Print sCtrl On Error Resume Next Set sf = ctl.Form If Err.Number = 0 Then sFormsList = sFormsList & sCtrl & ";" sFormsList = sFormsList & ListSubFrms1(sf) Else sFormsList = sFormsList & sCtrl & " - has no subform" & ";" End If On Error GoTo Error_Handler End If End Select Next ctl
Error_Handler_Exit: On Error Resume Next 'DoCmd.Close acForm, sFrm, acSaveNo Set frm = Nothing Set sf = Nothing Set ctl = Nothing ListSubFrms1 = sFormsList Exit Function
Error_Handler: MsgBox "The following error has occurred." & vbCrLf & vbCrLf & _ "Error Number: " & Err.Number & vbCrLf & _ "Error Source: ListSubFrms" & vbCrLf & _ "Error Description: " & Err.description, _ vbCritical, "An Error has Occurred!" Resume Error_Handler_ExitEnd Function
Private Sub ListSubFrms1_TEST() Dim sList As String Dim frm As Access.Form Const conFrm As String = "frmSettings" DoCmd.OpenForm conFrm Set frm = Forms(conFrm) sList = ListSubFrms1(frm) sList = VBA.Replace(sList, ";", vbCrLf, 2, , vbTextCompare) Debug.Print sList DoCmd.Close acForm, conFrm, acSaveNo Set frm = NothingEnd Sub

Don't Use VB>InStr()

Use this code in place of VBA.InStr which sees one word inside another

  • Returns True if the List contains an item matching the SearchString
  • Case insentitive

'03 Dec 2008 v3Function apListContains(sCommaSepList As String, ByVal sSearchString As String) As Boolean
 Dim arrList, v Dim bRetVal As Boolean
 '18 Dec 2008: Exit out if the sCommaSepList is an empty string If sCommaSepList <> "" Then arrList = VBA.Split(sCommaSepList, ",", -1, vbTextCompare) sSearchString = VBA.Replace(sSearchString, ",", "", , , vbTextCompare) '04 Jun 2009: Remove commas For Each v In arrList v = VBA.Replace(v, vbCrLf, " ", , , vbTextCompare) '02 Jun 2009: SQL may contain new line chr If VBA.LCase(VBA.Trim(sSearchString)) = VBA.LCase(VBA.Trim(v)) Then 'Remove spaces bRetVal = True Exit For End If Next arrList = Empty End If
ExitRoutine: apListContains = bRetValEnd Function
Private Sub apListContains_TEST()'Press F8 to step though this code to test Dim sRetVal As String sRetVal = apListContains("one, one-two , two_c,three", "") 'False sRetVal = apListContains("one, one-two , two_c,three", "two") 'False: 'two' does not wholly match any list item sRetVal = apListContains("one, one-two , two_c,three", ",two_c,") 'True: Commas and leading/trailing spaces are ignoredEnd Sub

Sort a String of Data

Sort a string of data in this VBA function and optionally choose sort order, data type and the separator

There's a test routine at the end so you can step through the code.


'Based on code at http://www.vbaexpress.com/kb/getarticle.php?kb_id=103'15 Dec 2008: Optional separator parameter'06 Jan 2009: Optional Data Type parameter for frmFilter_FE_InsStartDates_AftUp'03 Feb 2010: Optional Reverse Sort parameter (defaults to False)Function mlSort(sList As String, _ Optional sSep As String = ";", _ Optional nDataType As DataTypeEnum = dbText, _ Optional bReverseSort As Boolean = False) As String 'Sorts ;-sep list. Returns sorted list
 Dim arrList As Variant Dim nFirst As Integer, nLast As Integer, i As Integer, j As Integer, nStep As Integer Dim sTemp As String
 arrList = Split(sList, sSep) nFirst = LBound(arrList) nLast = UBound(arrList) For i = nFirst To nLast '02 Apr 2009: Trim spaces arrList(i) = VBA.Trim(arrList(i)) Next If bReverseSort = True Then '03 Feb 2010 nStep = nLast nLast = nFirst nFirst = nStep nStep = -1 Else nStep = 1 End If '03 Feb 2010: For i = nFirst To nLast ' - 1 For i = nFirst To nLast Step nStep '03 Feb 2010: For j = i + 1 To nLast For j = i + nStep To nLast Step nStep Select Case nDataType Case dbDate If VBA.CDate(arrList(i)) > VBA.CDate(arrList(j)) Then sTemp = arrList(j) arrList(j) = arrList(i) arrList(i) = sTemp End If Case dbText If arrList(i) > arrList(j) Then sTemp = arrList(j) arrList(j) = arrList(i) arrList(i) = sTemp End If Case Else If VBA.Val(arrList(i)) > VBA.Val(arrList(j)) Then sTemp = arrList(j) arrList(j) = arrList(i) arrList(i) = sTemp End If End Select Next j Next i
 mlSort = VBA.Trim(Join(arrList, sSep)) arrList = EmptyEnd Function
Private Sub mlSort_TEST() Dim sRetVal As String sRetVal = mlSort("RefundTTDTotalL1; SexL1; SexL2; Smoker; Term; RowNo") sRetVal = mlSort("5;3;11;8;1", , dbInteger) sRetVal = mlSort("15/1/2008,10/2/2008,1/1/2008", ",", dbDate) sRetVal = mlSort("15/1/2008,10/2/2008,1/1/2008", ",", dbText) sRetVal = mlSort("e;a;s;d;f;g") sRetVal = mlSort("e,a,s,d,f,g", ",") sRetVal = mlSort("200601;200602;200603", , dbLong, bReverseSort:=True) sRetVal = mlSort("200607;200605;200601;200602;200604;200603;200606", , dbLong, bReverseSort:=True) sRetVal = mlSort("200607;200605;200601;200602;200604;200603;200606", , dbLong, bReverseSort:=False)End Sub

Backup Your Access Modules

VBA code to export ALL modules including Form modules

Requires reference to Microsoft Scripting Runtime


'03 Jul 2013 v3; prev in OurDb v9.00Private Sub Modules_Export()'Code to export ALL modules including Form modules but not if new module not saved'Not yet able to export Form2 modules :-('12 May 2010: Module filenames are prefixed with program base name + '.' 'but will import without the prefix

 Const conModuleFolder As String = "Type your backup path here" Const conAOMod As String = ".cls", _ conForms2 As String = ".frm", _ conModules As String = ".bas", _ conClass As String = ".cls"
 Dim oMod As Access.Module Dim ao As AccessObject Dim n As Integer, nCount As Integer Dim nLines As Long, nLinesTot As Long Dim sModNameLst As String, sModName As String, sExt As String, sFileSpec As String Dim sFileBaseName As String, sTmp As String, sErrList As String Dim sNamePadded As String * 25, sLines As String * 5 Dim frm As Form Dim bRetVal As Boolean
 If fso.FolderExists(conModuleFolder) = False Then Stop sTmp = fso.GetBaseName(CurrentDb.Name) 'Prefix to file name sFileBaseName = VBA.Replace(sTmp, "Copy of ", "", 1, 1, vbTextCompare) apPathCreate conModuleFolder '12 May 2010: Create folder mlFormsClose "twaddle" nCount = CurrentProject.AllModules.Count + CurrentProject.AllForms.Count
On Error GoTo ErrHandler
 'Application.Echo EchoOn:=0 For Each ao In CurrentProject.AllModules 'Export Class and Modules sModName = ao.Name 'SAVED module only, not dirtied version sNamePadded = sModName 'For report DoCmd.OpenModule sModName Set oMod = Application.Modules(sModName) 'More info available in oMod than ao If oMod.Type = acClassModule Then sExt = conClass ElseIf oMod.Type = acStandardModule Then sExt = conModules Else Stop 'Unexpected Type End If sFileSpec = fso.BuildPath(conModuleFolder, sFileBaseName & "." & sModName & sExt) DoCmd.OutputTo acOutputModule, sModName, acFormatTXT, sFileSpec, AutoStart:=0 nLines = oMod.CountOfLines RSet sLines = CStr(nLines) sModNameLst = sModNameLst & vbCrLf & sNamePadded & sLines nLinesTot = nLinesTot + nLines If ao.IsLoaded = True Then DoCmd.Close acModule, ao.Name ', acSaveYes - cannot save within this loop End If Next 'Application.Echo EchoOn:=True mlFormsClose "twaddle"
 sExt = conAOMod For Each ao In CurrentProject.AllForms 'Export form modules sModName = ao.Name sNamePadded = sModName If ao.IsLoaded = False Then DoCmd.OpenForm sModName, acDesign, , , , acHidden 'Poss errors '14 Aug 13: Errs stopped by closing forms If Forms(sModName).HasModule = True Then Set oMod = Forms(sModName).Module sModName = oMod.Name sFileSpec = fso.BuildPath(conModuleFolder, sFileBaseName & "." & sModName & sExt) DoCmd.OutputTo acOutputModule, sModName, acFormatTXT, sFileSpec, AutoStart:=0 sNamePadded = sModName nLines = oMod.CountOfLines RSet sLines = CStr(nLines) sModNameLst = sModNameLst & vbCrLf & sNamePadded & sLines End If If (ao.IsLoaded = True) And (sModName <> "frm_Message") Then DoCmd.Close acForm, sModName End If mlFormsClose "twaddle"
AtNext: Next Set oMod = Nothing sNamePadded = "Module" sModNameLst = sNamePadded & "Lines" & _ mlSort(sModNameLst, vbCrLf) & vbCrLf & _ "Line count total = " & nLinesTot If sErrList <> "" Then sErrList = sErrList & vbCrLf & vbCrLf End If Debug.Print sErrList & sModNameLstExitRoutine:Exit Sub
ErrHandler: gnErr = Err.Number: gsErr = Err.description sErrList = sErrList & vbCrLf & sModName & ": error " & gnErr & ", " & gsErr If gnErr = 2450 Then '14 Aug 13: Cannot find the referenced form eg frmMessage - skip as it has no module Resume AtNext ElseIf gnErr = 7784 Then 'Object is already open for design... Resume AtNext Else Stop Resume End IfEnd Sub

'Support functions

'15 Jan 2004Sub apPathCreate(ByVal sTargetFolder As String) 'Creates the stated folders if not already exist 'Requires ref to FileSystemObject 'Exits if error
 Dim f As Variant, arrFolders As Variant Dim sPath As String Dim temp
 If fso.FolderExists(sTargetFolder) Then GoTo ExitRoutine
 sPath = fso.GetDriveName(sTargetFolder) If Right$(sPath, 1) = ":" Then sPath = sPath & "\" 'Fix for drive letter End If
 'Get folders after drive name temp = Mid$(sTargetFolder, Len(sPath) + 1)
 'Split path into array arrFolders = Split(temp, "\", , vbTextCompare)
On Error Resume Next
 For Each f In arrFolders If f <> gconEmpty Then sPath = fso.BuildPath(sPath, f) If fso.FolderExists(sPath) = False Then fso.CreateFolder sPath 'Poss err If Err > 0 Then Exit For End If Next
ExitRoutine:
 arrFolders = Empty
End Sub

'09 Jun 2009 v2Function mlFormsClose(Optional sExceptForm As String = "frm_Login") 'Closes all open forms, with an optional exception Dim o As Object Dim sForm As String For Each o In CurrentProject.AllForms If o.IsLoaded = True Then sForm = o.Name If (sForm = sExceptForm) Then 'Do not close the form exception Else DoCmd.Close acForm, sForm End If End If Next Set o = Nothing
End Function

'15 Feb 2008 v4'Based on code at http://www.vbaexpress.com/kb/getarticle.php?kb_id=103'15 Dec 2008: Optional separator parameter'06 Jan 2009: Optional Data Type parameter for frmFilter_FE_InsStartDates_AftUp'03 Feb 2010: Optional Reverse Sort parameter (defaults to False)Function mlSort(sList As String, _ Optional sSep As String = ";", _ Optional nDataType As DataTypeEnum = dbText, _ Optional bReverseSort As Boolean = False) As String 'Sorts ;-sep list. Returns sorted list
 Dim arrList As Variant Dim nFirst As Integer, nLast As Integer, i As Integer, j As Integer, nStep As Integer Dim sTemp As String

 arrList = Split(sList, sSep) nFirst = LBound(arrList) nLast = UBound(arrList) For i = nFirst To nLast '02 Apr 2009: Trim spaces arrList(i) = VBA.Trim(arrList(i)) Next If bReverseSort = True Then '03 Feb 2010 nStep = nLast nLast = nFirst nFirst = nStep nStep = -1 Else nStep = 1 End If '03 Feb 2010: For i = nFirst To nLast ' - 1 For i = nFirst To nLast Step nStep '03 Feb 2010: For j = i + 1 To nLast For j = i + nStep To nLast Step nStep Select Case nDataType Case dbDate If VBA.CDate(arrList(i)) > VBA.CDate(arrList(j)) Then sTemp = arrList(j) arrList(j) = arrList(i) arrList(i) = sTemp End If Case dbText If arrList(i) > arrList(j) Then sTemp = arrList(j) arrList(j) = arrList(i) arrList(i) = sTemp End If Case Else If VBA.Val(arrList(i)) > VBA.Val(arrList(j)) Then sTemp = arrList(j) arrList(j) = arrList(i) arrList(i) = sTemp End If End Select Next j Next i
 mlSort = VBA.Trim(Join(arrList, sSep)) arrList = EmptyEnd Function
Private Sub mlSort_TEST() temp = mlSort("RefundTTDTotalL1; SexL1; SexL2; Smoker; Term; RowNo") temp = mlSort("5;3;11;8;1", , dbInteger) temp = mlSort("15/1/2008,1/1/2008", ",", dbDate) temp = mlSort("e;a;s;d;f;g") temp = mlSort("e,a,s,d,f,g", ",") temp = mlSort("200601;200602;200603", , dbLong, bReverseSort:=True) temp = mlSort("200607;200605;200601;200602;200604;200603;200606", , dbLong, bReverseSort:=True) temp = mlSort("200607;200605;200601;200602;200604;200603;200606", , dbLong, bReverseSort:=False)End Sub

More to come

I'm working on it!