Manage Object Properties with VBA
Get and set ... read, write, show, delete

VBA Code

Read (Get), Write (Set), Delete, and Show property values for any object.

'*************** Code Start *****************************************************
' module name: mod_Properties_s4p      updated 10 June 2023
'-------------------------------------------------------------------------------
' Purpose  : set and get properties, show and delete
'              send object such as Database, Field, Control
'              if object not specified, CurrentDb is used and released
' Author   : crystal (strive4peace)
' Code List: www.MsAccessGurus.com/code.htm
' This code: https://msaccessgurus.com/VBA/Code/Properties.htm
' LICENSE  :
'   You may freely use and share this code, but not sell it.
'   Keep attribution. Use at your own risk.
'-------------------------------------------------------------------------------
' last update: specifically set obj if needed
' instead of using With since that doesn't seem to work anymore
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           Set_Property
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function Set_Property( _ 
   pPropName As String _ 
   ,pValue As Variant _ 
   ,Optional ByVal piDataType As Integer = 4 _ 
   ,Optional obj As Object _ 
   ,Optional bSkipMsg As Boolean = True _ 
   ) As Boolean 
'set or change a database (or object) property to specified value
'strive4peace
'8-9,130410,160820,170721,191107...1124,191205

   ' PARAMETERS
   '  pPropName is the (database) property name to set
   '  pValue is the value for the property
   ' optional:
   '  piDataType is the Data Type: dbBoolean, dbLong, dbText, ...
   '   default is Long Integer, 4
   '  obj = database, field, tabledef, querydef,
   '   or other object with properties
   '   if obj is not specified, then CurrentDb is used
   '  bSkipMsg = True: don't give user feedback
   '
   ' RETURN
   '  True if successful
   '
   'EXAMPLES
   ' Call Set_Property("AppTitle", sAppTitle, dbText, db)
   '     or Set_Property("AppTitle", sAppTitle, dbText)
   '        where
   '        sAppTitle is defined -- or a literal value
   ' Call Set_Property("AllowAutoCorrect", true, dbBoolean, oControl)
   ' Call Set_Property("Description", "my field description", dbText, oField)
   
   'set up Error Handler
   On Error GoTo Proc_Err 
   Set_Property = False 
   
   Dim bRelease As Boolean _ 
      ,iNumTries As Integer _ 
      ,sMsg As String 

   bRelease = False 
   iNumTries = 0 
   
   If obj Is Nothing Then 
      Set obj = CurrentDb 
      bRelease = True 
   End If 

   'assume property is defined
   obj.Properties(pPropName) = pValue 
   Set_Property = True 
   
Proc_Done: 
   On Error Resume Next 
   sMsg = pPropName &  " Is " _ 
      & pValue _ 
      &  " For " & obj.Name 
Debug.Print Now(),sMsg 
   If Not bSkipMsg Then 
      MsgBox sMsg,, "Done"
   End If 

Proc_exit: 
   On Error Resume Next 
   If bRelease = True Then Set obj = Nothing 
   Exit Function 

Proc_CreateProperty: 
      obj.Properties.Append obj.CreateProperty( _ 
         pPropName,piDataType,pValue) 
      Set_Property = True 
      GoTo Proc_Done 
      
Proc_Err: 
   'property is not defined
   iNumTries = iNumTries + 1 

   If piDataType <> 0 Then 
      If iNumTries > 1 Then 
         sMsg =  "ERROR setting " & pPropName &  " To " _ 
            & pValue _ 
            &  " For " & obj.Name 
         Debug.Print Now(),sMsg 
      
         If Not bSkipMsg Then 
            MsgBox sMsg,, "ERROR"
         End If 
         Resume Proc_exit 
      End If 
      Resume Proc_CreateProperty 
   End If 
   
   Resume Proc_Done 
   Resume 
End Function 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           Get_Property
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function Get_Property( _ 
   psPropName As String _ 
   ,Optional obj As Object _ 
   ,Optional pvDefaultValue As Variant _ 
   ) As Variant 
' get the value of a database (or object) property
' pass (optional) object to look somewhere other than CurrentDb
' pass (optional) default value to return if property not set
's4p 8-9 ... 130831, 160820, 170721, 191124, 200511, 220403
    
   ' PARAMETERS
   '  psPropName is the (database) property name to return the value of
   ' OPTIONAL
   '  obj = database, field, tabledef, querydef,
   '   or other object with properties
   '   if obj is not specified, then CurrentDb is used
   '  pvDefaultValue is value to return if property cannot be read
   '
   'RETURNS
   ' Value of property
   ' OR Null (or pvDefaultValue) if property has no value or isn't defined
    
   'EXAMPLES
   '  MyValue = Get_Property("MyDatabasePropertyName")
   '  MyFieldDescription = Get_Property("Description",oField,"")
   ' ?Get_Property("Description",currentdb.TableDefs("MyTable").fields("MyField"))
   
   On Error GoTo Proc_Err 
   
   Dim bRelease As Boolean 
   bRelease = False 

   If obj Is Nothing Then 
      Set obj = CurrentDb 
      bRelease = True 
   End If 

   'initialize return value
   If Not IsMissing(pvDefaultValue) Then 
      Get_Property = pvDefaultValue 
   Else 
      Get_Property = Null 
   End If 
      
   With obj 
      Get_Property = obj.Properties(psPropName) 
   End With 
      
Proc_exit: 
   On Error Resume Next 
   If bRelease Then Set obj = Nothing 
   Exit Function 
  
Proc_Err: 
   Resume Proc_exit 

End Function 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           Delete_Property
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Sub Delete_Property( _ 
   psPropName As String _ 
   ,Optional obj As Object _ 
   ) 
'140226,191122 strive4peace, 210811, 230514
   
   ' PARAMETERS
   '  psPropName is the (database) property name to return the value of
   ' OPTIONAL
   '  obj = database, field, tabledef, querydef,
   '   or other object with properties collection
   '   if obj is not specified, then CurrentDb is used
   
   'EXAMPLE
   '  Delete_Property "calendar_QueryName"
   '     delete the "calendar_QueryName" property for the current database

   On Error GoTo Proc_Err 
   
   Dim sMsg As String 
   Dim bRelease As Boolean  '230514
   bRelease = False 
   
   If obj Is Nothing Then 
      Set obj = CurrentDb 
      bRelease = True 
   End If 
   
   With obj  '210811 s4p, 230514
      .Properties.Delete (psPropName) 
      sMsg =  "Deleted " & psPropName _ 
         &  " in " & .Name 
   End With 

   Debug.Print  "*" & Now(),sMsg 
      
Proc_exit:  '230514
   On Error GoTo 0 
   If bRelease Then Set obj = Nothing 
   Exit Sub 
  
Proc_Err: 

   Resume Proc_exit 
   
End Sub 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           IsPropertyDefined
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function IsPropertyDefined( _ 
   ByVal pPropName As String _ 
   ,Optional obj As Object _ 
   ,Optional vValueReturn As Variant _ 
   ) As Boolean 
'121127, 130429, 210811, 230514
   'Crystal, strive4peace

   'PARAMETERS
   ' Obj can be a database, a Tabledef, a Field...
   ' if it is missing, CurrentDb is used
   '
   On Error GoTo Proc_Err 
   
   IsPropertyDefined = False 
   
   Dim bRelease As Boolean  '230514
   bRelease = False 
   If obj Is Nothing Then 
      Set obj = CurrentDb 
      bRelease = True 
   End If 
   
   With obj  '230610 s4p
      vValueReturn = .Properties(pPropName) 
   End With 
   
   IsPropertyDefined = True 
   
Proc_exit:  '230514
   On Error GoTo 0 
   If bRelease Then Set obj = Nothing 
   Exit Function 
  
Proc_Err: 
   Resume Proc_exit 
   
End Function 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           Show_Properties
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub Show_Properties( _ 
    Optional obj As Object _ 
    ,Optional psStartCharacters As String =  "" _ 
   ) 
'crystal (strive4peace) ...191122, 210811,230610
'output each property type, name, and value to the Immediate (Debug) window
' WizHook is used to sort the array before displaying it

   ' OPTIONAL PARAMETER
   '  obj = database, field, tabledef, querydef,
   '   or other object with properties collection
   '   if obj is not specified, then CurrentDb is used
   '  psStartCharacters is what the property names you want to see start with
   
   'EXAMPLES
   '  Call Show_Properties( ,"calendar_")
   '     see all database property names that start with "calendar_"
   '  Show_Properties
   '     see all database property information
   
   Dim oProperty As Property 
   Dim i As Integer 
   Dim aPropertyName() As String 
   Dim iNumberProperties As Integer 
   Dim bRelease As Boolean  '230610
   
   On Error Resume Next 
   
   If obj Is Nothing Then 
      Set obj = CurrentDb 
      bRelease = True 
   End If 
   
   'load properties into an array
   With obj 
      iNumberProperties = .Properties.Count 
      ReDim aPropertyName(1 To iNumberProperties) 
      i = 1 
      For Each oProperty In .Properties 
         If psStartCharacters =  "" _ 
            Or Left(.Name,Len(psStartCharacters)) = psStartCharacters _ 
            Then 
      
            aPropertyName(i) = oProperty.Name 
            i = i + 1 
         End If 
      Next oProperty 
      i = i - 1   'last value
            
      If i <> iNumberProperties Then 
         iNumberProperties = i 
         ReDim aPropertyName(1 To iNumberProperties) 
      End If 
   End With 
   
   'sort array
   WizHook.SortStringArray aPropertyName 
   
   With obj
      For i = LBound(aPropertyName) To UBound(aPropertyName) 
         With .Properties(aPropertyName(i)) 
            'show all or filter for start characters
               Debug.Print 
               Debug.Print i &  ".   " & .Type; Tab(10); .Name; 
                  Debug.Print  " = " & .Value; 
         End With    'oProperty
      Next i 
      
   End With 
   
   Debug.Print 
   Debug.Print  "*** " & iNumberProperties &  " properties listed",Now() 

   Set oProperty = Nothing 

Proc_exit: 
   On Error GoTo 0 
   If bRelease Then Set obj = Nothing 
End Sub 

'
'=================================================================
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           Launch Examples
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'~~~~~~~~~~~~~~~~~~~~~~~ Launch_Set_Property_AppTitle
Public Sub Launch_Set_Property_AppTitle() 
'170721 s4p
'  set database application title to path\file of current database
'
   Dim sAppTitle As String 
   Dim db As DAO.Database 
   Set db = CurrentDb 
   
   'set titlebar to path and file of current database
   sAppTitle = db.Name 
   
   Call Set_Property( "AppTitle",sAppTitle,dbText,db) 
   Set db = Nothing 

End Sub 

'~~~~~~~~~~~~~~~~~~~~~~~ Launch_Get_Property_AppTitle
Public Sub Launch_Get_Property_AppTitle() 
'170721 s4p
   MsgBox Get_Property( "AppTitle") _ 
      ,, "AppTitle Property For Current Database"
End Sub 

'~~~~~~~~~~~~~~~~~~~~~~~ Launch_Get_Property_variousDatabase
Public Sub Launch_Get_Property_variousDatabase() 
'170721 s4p
' write information to the Immediate (Debug) window
' about various current database properties

   On Error GoTo Proc_Err 
   
   Dim db As DAO.Database 
   Set db = CurrentDb 
   
   Dim sValue As String _ 
      ,sPropertyName As String _ 
      ,sMsg As String _ 
      ,i As Integer 

   Dim avProperty() As Variant  'must be Variant to use Array function
   'my note: alternately, could store as string and then Split to Array
   avProperty = Array( _ 
      "AppTitle" _ 
      , "StartUpForm" _ 
      , "StartUpShowStatusBar" _ 
      , "StartUpShowDBWindow" _ 
      , "ShowDocumentTabs" _ 
      , "AllowSpecialKeys" _ 
      , "Auto Compact" _ 
      , "Picture Property Storage Format" _ 
      , "Themed Form Controls" _ 
      , "AllowFullMenus" _ 
      , "AllowShortcutMenus" _ 
      , "AllowBuiltInToolbars" _ 
      , "Show Values Limit" _ 
      , "Track Name AutoCorrect Info" _ 
      , "Perform Name AutoCorrect" _ 
      , "NavPane Category" _ 
      , "Show Navigation Pane Search Bar" _ 
      , "NavPane Closed" _ 
      , "NavPane Width" _ 
      , "NavPane View By" _ 
      , "NavPane Sort By" _ 
      , "Version" _ 
      ) 

   sMsg =  ""
   
   For i = LBound(avProperty) To UBound(avProperty) 
      sPropertyName = avProperty(i) 
      'call Get_Property
      sMsg = sMsg & vbCrLf _ 
         & Space(3) & sPropertyName _ 
         &  " = " _ 
         & Get_Property(sPropertyName,db) 
   Next i 
   
   Debug.Print  "*** Various Properties For " _ 
      & db.Name _ 
      &  ", " & Now() _ 
      & sMsg 
   MsgBox sMsg,, "Various Properties For Current Database"
      
Proc_exit: 
   On Error GoTo 0 
   Set db = Nothing 

   Exit Sub 
  
Proc_Err: 
   MsgBox Err.Description,, _ 
        "ERROR " & Err.Number _ 
        &  "   Launch_Get_Property_variousDatabase"

   Resume Proc_exit 
   Resume 
   
End Sub 
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'     set properties in another database
'~~~~~~~~~~~~~~~~~~~~~~~ Set_AllowSpecialKeys to True in other database
Sub Set_AllowSpecialKeys() 
   Dim db As DAO.Database 
   '           -------------------- customize path\file for your database
   Set db = OpenDatabase( "C:\Data\MyDatabase.accdb") 
   'False=don't skip message
   Call Set_Property( "AllowSpecialKeys",True,dbBoolean _ 
         ,db,False) 
   db.Close 
   Set db = Nothing 
End Sub 
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           Specific Examples
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'     set, get, or delete a property called contact_CID
'~~~~~~~~~~~~~~~~~~~~~~~ get the value of "contact_CID"
Function Get_CurrentCID(Optional pvDefaultValue As Long = 0) As Long 
   Get_CurrentCID = Get_Property( "contact_CID",,pvDefaultValue) 
End Function 
'~~~~~~~~~~~~~~~~~~~~~~~ set the value of "contact_CID"
Sub Set_CurrentCID(Optional pnCID As Long) 
   Call Set_Property( "contact_CID",pnCID,dbLong) 
End Sub 
'~~~~~~~~~~~~~~~~~~~~~~~ delete the "contact_CID" database property
Sub Delete_CurrentCID(Optional pnCID As Long) 
   Call Delete_Property( "contact_CID") 
End Sub 
'*************** Code End *******************************************************

Keywords and comments in code were colored with this free Color Code add-in

Goto Top  

Goto Top  

Goto Top