' типы полей таблиц
' 0 - неопределённый
' 1 -
' 2 - обычное целое
' 3 - длинное целое
' 4 - с плавающей точкой одинарной точности
' 5 - с плавающей точкой двойной точности
' 6 - денежный
' 7 - дата
' 8 -
' 9 -
' 10 - ошибка (adError)
' 11 - логический
' 14 - десятичный
' 16 - байт - не срабатывает, выдаёт ошибку
' 20 - двойное длинное целое
' 130 - adWChar
' 202 - adVarWChar - символьная переменной длины

'---------------------------------------------------------------------------------------
' Procedure : sbCreate_tbl_Company
' DateTime  : 10.03.2013 09:43
' Author    : Admin
' Purpose   : Создание таблицы tbl_Company
'---------------------------------------------------------------------------------------
'
Public Sub sbCreate_tbl_Company_ADO()

   On Error GoTo sbCreate_tbl_Company_ADO_Error

Dim cat As ADOX.Catalog
Dim tbl As ADOX.Table
Dim Clmn As ADOX.Column
Dim cnn As ADODB.Connection
Dim idx As ADOX.Index

Dim strConnection As String
Dim strBaseName As String
Dim strTableName As String
Dim strFieldName(19) As String
Dim strDescription(19) As String
Dim intTypeField(19) As Integer
Dim intDefinedSize(19) As Integer
Dim i As Integer

Dim strCurBaseName As String

strBaseName = "Hotel_ms" ' внешняя база данных в формате mdb
strTableName = "tbl_Company"
strFieldName(1) = "IdCompany"
strFieldName(2) = "CompanyFullName"
strFieldName(3) = "CompanyShortName"
strFieldName(4) = "CompanyAcronym"
strFieldName(5) = "idCompanyType"
strFieldName(6) = "DefAccount"
strFieldName(7) = "DefCountry"
strFieldName(8) = "DefPostIndex"
strFieldName(9) = "DefCity"
strFieldName(10) = "DefStreet"
strFieldName(11) = "DefBuilding"
strFieldName(12) = "DefOffice"
strFieldName(13) = "DefPhone"
strFieldName(14) = "DefFax"
strFieldName(15) = "DefEmail"
strFieldName(16) = "Comment"
strFieldName(17) = "CommissionP"
strFieldName(18) = "CommissionD"
strFieldName(19) = "Actuale"

intTypeField(1) = 3
intTypeField(2) = 202
intTypeField(3) = 202 
intTypeField(4) = 202
intTypeField(5) = 202
intTypeField(6) = 202
intTypeField(7) = 202
intTypeField(8) = 202
intTypeField(9) = 202
intTypeField(10) = 202
intTypeField(11) = 202
intTypeField(12) = 202
intTypeField(13) = 202
intTypeField(14) = 202
intTypeField(15) = 202
intTypeField(16) = 202
intTypeField(17) = 4
intTypeField(18) = 6
intTypeField(19) = 11

strDescription(1) = "Идентификатор записи"
strDescription(2) = "Полное название"
strDescription(3) = "Короткое название (для поиска)"
strDescription(4) = "аббревиатура названия компании: ОАО вместо Открытое акционерное общество"
strDescription(5) = "Идентификатор типа компании"
strDescription(6) = "Р/С по умолчанию"
strDescription(7) = "Страна"
strDescription(8) = "Почтовый индекс"
strDescription(9) = "Город"
strDescription(10) = "Улица"
strDescription(11) = "Дом"
strDescription(12) = "Офис"
strDescription(13) = "Контактный телефон"
strDescription(14) = "Факс"
strDescription(15) = "Эл. почта"
strDescription(16) = "Комментарий"
strDescription(17) = "Комиссия, процент"
strDescription(18) = "Комиссия, сумма"
strDescription(19) = "Признак актуальности записи"

intDefinedSize(2) = 255
intDefinedSize(3) = 150
intDefinedSize(4) = 150
intDefinedSize(5) = 150
intDefinedSize(6) = 100
intDefinedSize(7) = 100
intDefinedSize(8) = 12
intDefinedSize(9) = 255
intDefinedSize(10) = 60
intDefinedSize(11) = 60
intDefinedSize(12) = 40
intDefinedSize(13) = 100
intDefinedSize(14) = 80
intDefinedSize(15) = 80
intDefinedSize(16) = 255


Set cnn = New ADODB.Connection
Set cat = New ADOX.Catalog
strConnection = CurrentProject.Connection

If CurrentProject.FileFormat < 12 Then ' проверка версии формата файла БД < Access2007
If CurrentProject.Name = strBaseName & ".mdb" Then
    cat.ActiveConnection = CurrentProject.Connection
Else
    strConnection = Replace(strConnection, CurrentProject.Name, strBaseName & ".mdb")
    cnn.ConnectionString = strConnection
    cnn.Open
    cat.ActiveConnection = cnn.ConnectionString
End If

Else
' здесь должна быть обработка для файла формата accdb
End If

Set tbl = New ADOX.Table
'Создание фактической таблицы
With tbl
    .Name = "tbl_Company"
    For i = 1 To 19
    Set Clmn = New ADOX.Column
    With Clmn
        .ParentCatalog = cat
        .Name = strFieldName(i) 'YourFldName
        .Type = intTypeField(i)
        Select Case i
            Case 17, 18
                .Properties("Default").Value = 0
            Case 19
                .Properties("Default").Value = True
            Case Else
                .Properties("Default").Value = ""
        End Select
        Select Case i
            Case 1, 2, 3, 19
                .Properties("Nullable").Value = False
            Case Else
                .Properties("Nullable").Value = True
         End Select
         If i = 1 Then .Properties("AutoIncrement").Value = True    ' будет счетчик
         Select Case i
            Case 2 To 16
                .DefinedSize = intDefinedSize(i)
            Case Else
         End Select
       .Properties("Description").Value = strDescription(i)
   End With
   tbl.Columns.Append Clmn
   tbl.Columns.Refresh
   Set Clmn = Nothing
   Next

End With

'Добавление в каталог таблицы
cat.Tables.Append tbl
' обновляю данные о таблицах
cat.Tables.Refresh

'Создание объекта индекса
Set idx = New ADOX.Index
'Определение индекса в качестве первичного ключа и задание порядка сортировки по убыванию
With idx
    .Name = "PrimaryKey"
    .Columns.Append "IdCompany"
'    .Columns("TimeIntervalName").SortOrder =   adSortDescending
    .IndexNulls = adIndexNullsDisallow
    .PrimaryKey = True
End With
'Добавление индекса в таблицу
tbl.Indexes.Append idx

'Очистка

Set idx = Nothing
Set tbl = Nothing
    
Set cat = Nothing

    If CurrentProject.Name = strBaseName Then
    Else
        cnn.Close
    End If
    Set cnn = Nothing
   

   On Error GoTo 0
Exit_sbCreate_tbl_Company_ADO:
   Exit Sub

sbCreate_tbl_Company_ADO_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure sbCreate_tbl_Company_ADO"
    Resume Exit_sbCreate_tbl_Company_ADO
End Sub