Проверка всех таблиц на наличие полей с подстановкой и возможностью удаления этого свойства (опционально)

Public Sub PrintAllLookupFields(Optional blnFixLookUpProperty As Boolean) 'Поля с подстановкой долой!
' es 05.08.2019 - LE 12.03.2024 v005
' Проверка всех таблиц на наличие полей с подстановкой и возможностью удаления этого свойства
' Информация выводится в Immediate Window (Ctrl + G)
'--------------------------------------------------------------------------
'Аргумент: blnFixLookUpProperty = Признак исправления свойства сразу после обнаружения
'          (по умолчанию = False - только информация в Immediate Window)
'--------------------------------------------------------------------------
'Пример запуска в режиме инфомирования:
'    Call PrintAll_LookupFields_in_Tables
'Пример запуска с исправлением:
'    PrintAll_LookupFields_in_Tables True
'(на всякий случай - предварительно сделайте резервную копию БД)
'--------------------------------------------------------------------------
Dim tdf As DAO.TableDef, objField As DAO.Field
Dim objPrp As Property
Dim blnHasLookUpProperty As Boolean
Dim sVal$, sTableName$, sFieldName$, sPrpName$, iTablesCount%, iLookUpFieldsCount%
Const iLineLength% = 100

'Перебор всех таблиц кроме системных
    For Each tdf In CurrentDb.TableDefs
        If (tdf.Attributes And dbSystemObject) = False Then ' кроме системных
            sTableName = tdf.Name
            iTablesCount = iTablesCount + 1 'Учёт
            
            'Перебор всех полей таблицы
            For Each objField In tdf.Fields
                
                'Наличие свойства "DisplayControl"
                blnHasLookUpProperty = CheckProperty(objField, "DisplayControl")
                If blnHasLookUpProperty = True Then
                    sFieldName = objField.Name
                    Set objPrp = objField.Properties("DisplayControl")

                    If objPrp.Value = acComboBox Or objPrp.Value = acListBox Then
                        iLookUpFieldsCount = iLookUpFieldsCount + 1 'Учёт ошибок
                        
                        If blnFixLookUpProperty = True Then 'Если заказано - испраляем:
                            If Not objField.Type = 1 Then ' Is Not Logical (Yes/No)
                                objPrp.Value = acTextBox
                                sVal = "- исправлено на 109 (acTextBox)."
                            Else                          ' Is Logical
                                objPrp.Value = acCheckBox
                                sVal = "- исправлено на 106 (acCheckBox)."
                            End If
                            
                            sVal = vbTab & "Табл: [" & sTableName & "]" & _
                                " - Поле: [" & sFieldName & "] " & _
                                "Свойство: [DisplayControl] " & sVal
                        Else
                            sVal = "Таблица: [" & sTableName & "]" & _
                                " - Поле с подстановкой : [" & sFieldName & "]"
                        End If
                        Debug.Print sVal
                    End If  ' objPrp.Value = acComboBox Or ...
                End If      ' blnHasLookUpProperty = True
            Next objField
        End If
    Next tdf
    
    If iLookUpFieldsCount > 0 Then  'Найдены ...
        Debug.Print String(iLineLength, "-") 'Линия под результатами
        If blnFixLookUpProperty = False Then
            sVal = "Обработано: " & iTablesCount & " таблиц" & _
                " - Найдено полей с подстановкой : " & iLookUpFieldsCount
        Else
            sVal = "Обработано: " & iTablesCount & " таблиц" & _
                " - Исправлено полей с подстановкой : " & iLookUpFieldsCount
        End If
    Else 'Ничего не найдено - УРА!
        sVal = "Обработано: " & iTablesCount & " таблиц и полей с подстановкой не найдено!"
    End If
    Debug.Print sVal
    Debug.Print String(iLineLength, "=") 'Линия под отчётом
End Sub

Private Function CheckProperty(obj As Object, sPrpName$) As Boolean
'es - 19.07.2020 - LE 12.03.2024 v002
'Впомогательная функция - проверяет наличие заданного в аргументе свойства
'   у обьекта переданного в аргументе obj
' ------------------------------------------------------
Dim sVal$: On Error GoTo CheckPropertyPresent_Err
    sVal = obj.Properties(sPrpName): CheckProperty = True
    Exit Function
CheckPropertyPresent_Err:
    Err.Clear
End Function