VBA, MS Access MS Access в примерах

Вывод в Immediate Window списка всех полей БД со свойством подстановки


Private Sub PrintAll_LookupFields_in_Tables()
' es 05.08.2019
' Проверка всех таблиц на наличие постановочных полей с возможностью удаления этого свойтва
' Выводим в Immediate Window:
' Список всех полей со свойством подстановки (Название Таблицы - Название поля)
'--------------------------------------------------------------------------
'Field.Properties("DisplayControl").Value = 111 или 110 (ComboBox или ListBox)
'--------------------------------------------------------------------------
Dim tdf As DAO.TableDef
Dim objField As DAO.Field
Dim objPrp As Property
Dim s$, sTName$, sFLDName$, sPRPName$, iTbls%, iErr%, iPrp%
    
'Линия над результатами:
    Debug.Print String(64, "-")
    
    For Each tdf In CurrentDb.TableDefs 'Перебор таблиц
        If (tdf.Attributes And dbSystemObject) = False Then
            sTName = tdf.Name
            iTbls = iTbls + 1 'Учёт
            For Each objField In tdf.Fields 'Перебор всех полей таблицы
                sFLDName = objField.Name
                
                For Each objPrp In objField.Properties 'Перебор всех свойтв поля
                    sPRPName = objPrp.Name
                    If sPRPName = "DisplayControl" Then 'Есть свойство для Lookup!
                        iPrp = iPrp + 1 'Учёт найденных свойств
                        s = "Табл: [" & sTName & "] - Поле: [" & sFLDName & _
                            "] - ненужное свойство [DisplayControl]."
                        Debug.Print s
                        
                        
                        'Если это: ComboBox или ListBox (!!!) - а бывают "умельцы"
                        If objPrp.Value = 111 Or objPrp.Value = 110 Then
                            iErr = iErr + 1 'Учёт ошибок
                            s = "Табл: [" & sTName & _
                                "] - Поле с подстановкой : " & sFLDName
                            Debug.Print s
                        End If
                        'Удаление свойства целиком !!! (если нужно)
                        'objField.Properties.Delete objPrp.Name
                        s = vbTab & "Табл: [" & sTName & "] - Поле: [" & sFLDName & _
                            "] Свойство: [" & sPRPName & "] - удалено."
                        'Debug.Print s
                    End If
                Next objPrp
            Next objField
        End If
    Next tdf
    
    If iErr + iPrp > 0 Then 'Найдены ...
        s = "Найдено ненужных свойств [DisplayControl]: " & iPrp & _
            " Найдено полей с подстановкой : " & iErr
        'MsgBox s, vbCritical
        Debug.Print String(64, "-") 'Линия под результатами
    Else 'Ничего не найдено - УРА!
        s = "Обработано: " & iTbls & " таблиц - полей с подстановкой не найдено - УРА!"
        
        'MsgBox s, vbInformation
    End If
    Debug.Print s
End Sub

Назад ToTop
L.E. 05.08.2019
Рейтинг@Mail.ru