Выдрано из живой программы Использован метод ADO
' типы полей таблиц
' 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