TopPicLogo TopPicText

Автоматическое обнуление подтаблиц в базе данных (для повышения производительности)

По материалам: https://support.microsoft.com/ru-ru/kb/275085

Чтобы автоматически присвоить свойству Имя подтаблицы для всех несистемных таблиц в базе данных значение [ОТСУТСТВУЕТ], можно воспользоваться функцией на языке VBA (Visual Basic for Applications). Для этого выполните указанные ниже действия.

    01. Откройте базу данных таблиц.
    02. В окне базы данных нажмите кнопку Модули, а затем — Создать.
    03. В меню Tools выберите пункт References. Убедитесь, что флажок Microsoft DAO 3.6 Object Library установлен, и нажмите кнопку ОК.
    04. Вставьте в новый модуль приведенный ниже код.


Sub TurnOffSubDataSheets()
'Снятие ссылок Субтаблиц у всех таблиц базы для повышения производительности (по сети)
'--------------------------------------------------------------------
Dim MyDB As DAO.Database
Dim MyProperty As DAO.Property
Dim propName As String, propVal As String, rplpropValue As String
Dim propType As Integer, i As Integer
Dim intCount As Integer

On Error GoTo tagError

    Set MyDB = CurrentDb
    propName = "SubDataSheetName"
    propType = 10
    propVal = "[None]"
    rplpropValue = "[Auto]"
    intCount = 0

    For i = 0 To MyDB.TableDefs.Count - 1
        If (MyDB.TableDefs(i).Attributes And dbSystemObject) = 0 Then
            If MyDB.TableDefs(i).Properties(propName).Value = rplpropValue Then
                 MyDB.TableDefs(i).Properties(propName).Value = propVal
                 intCount = intCount + 1
            End If
        End If
tagFromErrorHandling:
    Next i

    MyDB.Close

    If intCount = 0 Then
        MsgBox "The " & propName & " value for " & intCount & _
        " non-system tables has been updated to " & propVal & "."
    End If
Exit Sub

tagError:
    If Err.Number = 3270 Then
        Set MyProperty = MyDB.TableDefs(i).CreateProperty(propName)
        MyProperty.Type = propType
        MyProperty.Value = propVal
        MyDB.TableDefs(i).Properties.Append MyProperty
        intCount = intCount + 1
        Resume tagFromErrorHandling
    Else
        MsgBox Err.Description & vbCrLf & vbCrLf & " in TurnOffSubDataSheets routine."
    End If
End Sub

    05. В окне Immediate (Ctrl+G) введите следующий текст и нажмите клавишу ENTER, чтобы выполнить процедуру.


    TurnOffSubDataSheets
			

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