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

Создание Таблицы "Digits" и заполнение её значениями (DAO)

Private Sub CreateDigitsTable()
'27.10.2022 v001 - Создание Таблицы "Digits" и заполнение её значениями
'---------------------------------------------------------------------------------------------------
Const csTableName$ = "Digits"  'Название таблицы
Const csFieldName$ = "Digit"   'Название поля
Const ciTotRecords% = 100      'Кол-во добавляемых записей

Dim tbl As TableDef       'объект таблица
Dim idx As index          'объект индекс
Dim fld As Field          'объект поле
Dim rst As Recordset      'объект набор записей
Dim iVal%
'---------------------------------------------------------------------------------------------------
'Удаляем существующую (если есть)
    On Error Resume Next
    CurrentDb.TableDefs.Delete csTableName
    Err.Clear
    
On Error GoTo CreateDigitsTable_Err

'Создание объектной переменной таблицы, полей и индекса в ней
    Set tbl = CurrentDb.CreateTableDef(csTableName)
    With tbl
        Set fld = tbl.CreateField(csFieldName, dbLong)
        fld.Attributes = dbAutoIncrField   'Счётчик!
        .Fields.Append fld
    'Создание уникального индекса:
            Set idx = .CreateIndex("Primary Key")
                With idx  'Добавление поля в индекс
                    .Fields.Append .CreateField(csFieldName)
                'Установка свойств индекса:
                    .Unique = True   'Уникальный
                    .Primary = True  'Первичный
                End With
            .Indexes.Append idx 'Индекс создан
    End With
'Фактическое добавление таблицы из объектной переменной описанной выше
    CurrentDb.TableDefs.Append tbl
    
'---------------------------------------------------------------------------------------------------
'Заполнение записями:
    Set rst = CurrentDb.OpenRecordset("Digits", dbOpenDynaset)
    For iVal = 1 To ciTotRecords
        With rst
            .AddNew: .Update
        End With
    Next iVal
    
CreateDigitsTable_Bye:
    On Error Resume Next
    Set idx = Nothing:    Set tbl = Nothing
    rst.Close:            Set rst = Nothing
    Exit Sub

CreateDigitsTable_Err:
    MsgBox "Произошла ошибка при выполнении процедуры [CreateDigitsTable] :" & vbCrLf & _
        Err.Description & vbCrLf & "Номер ошибки:" & Err.Number, vbCritical
    Resume CreateDigitsTable_Bye
End Sub

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