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

Создадание таблицы с различными типами полей

Private Sub CreateTableAndFields()
'Создадание таблицы с различными типами полей
'Хорошая статья:
'http://allenbrowne.com/ser-49.html

Dim strTableName As String ' Название таблицы
Dim tbl As Dao.TableDef    ' объект таблица
Dim fld As Dao.Field
        
        strTableName = "Table_Test"
        
     
' Удаляем прошлое
    On Error Resume Next
    CurrentDb.TableDefs.Delete strTableName
    Err.Clear


On Error GoTo CreateTableAndFields_Err

        
'создание объектной переменной таблицы, полей и индекса в ней
    Set tbl = CurrentDb.CreateTableDef(strTableName)
    With tbl
        .Fields.Append tbl.CreateField("fldText", dbText, 255)    'короткий текст
        .Fields.Append tbl.CreateField("fldMemo", dbMemo)         'Memo (длинный текст)
        .Fields.Append tbl.CreateField("fldDouble", dbDouble)     'числовой Double
        .Fields.Append tbl.CreateField("fldLong", dbLong)         'BigInt = Long Integer
        .Fields.Append tbl.CreateField("fldDate", dbDate)         'Дата время
        .Fields.Append tbl.CreateField("fldCurrency", dbCurrency) 'Денежный
        

        'Long Integer - счётчик
        Set fld = tbl.CreateField("fldAutoKey", dbLong)
        With fld 'Определение свойств поля
            .Attributes = dbAutoIncrField
        End With
        .Fields.Append fld 'Добавление
        
        .Fields.Append tbl.CreateField("fldBoolean", dbBoolean) 'Логический
    
        'OLE = 11 = dbLongBinary
        .Fields.Append tbl.CreateField("fldOLE", dbLongBinary)

        'Гиперссылка
        Set fld = tbl.CreateField("fldHyperlink", dbMemo) '!!! 12
         With fld 'Определение свойств поля
            .Attributes = dbHyperlinkField
        End With
        .Fields.Append fld 'Добавление

        'Attachment = 101 = dbAttachment
        .Fields.Append tbl.CreateField("fldAttachment", dbAttachment) 'Вложение
    End With


' Фактическое добавление таблицы из объектной переменной описанной выше
    CurrentDb.TableDefs.Append tbl
    CurrentDb.TableDefs.Refresh


CreateTableAndFields_Bye:
    On Error Resume Next
    Set tbl = Nothing
    Set fld = Nothing
    Exit Sub
        
CreateTableAndFields_Err:
    MsgBox "Произошла ошибка при выполнении процедуры " & _
            "[CreateTable01] :" & vbCrLf & _
            Err.Description & vbCrLf & _
            "Номер ошибки = " & Err.Number, vbCritical
    Err.Clear
    Resume CreateTableAndFields_Bye
End Sub

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