С помощью программных средств VBA создать мини-СУБД, используя заданную вариантом структуру данных

Private Sub Соэдать_базу()
 
Dim strFileType As String
On Error GoTo ErrorHandler
CommonDialog1.CancelError = True
CommonDialog1.FileName = Empty
strFileType = "MS Access Database (*.mdb)|*.mdb|"
 
CommonDialog1.Filter = strFileType
CommonDialog1.FilterIndex = 1
CommonDialog1.DialogTitle = "Введите имя создаваемой БД"
CommonDialog1.InitDir = "c:\"
CommonDialog1.Action = 1
 
'***********************************************
'Инициализируем переменныю пути к БД
strDBPath = CommonDialog1.FileName
'Если БД существовала
'Закрываем БД и рабочее пространство
NewDB.Close
NewWs.Close
'Уничтожаем объекты
Set NewTbl = Nothing
Set NewDB = Nothing
Set NewWs = Nothing
'Устанавливаем опции
lngDBOpts = dbVersion30 + dbEncrypt
'Создаем рабочее пространство
Set NewWs = DBEngine.Workspaces(0)
'Создаем Базу Данных
Set NewDB = NewWs.CreateDatabase(strDBPath, dbLangCyrillic, lngDBOpts)
 
MsgBox "База Данных " & CommonDialog1.FileTitle & _
" создана.", vbInformation, "Создание Баз Данных"
 
'***********************************************
'Разрешение на дальнейшие дествия Шаг2.
Frame1.Enabled = True
Command2.Enabled = True
Command3.Enabled = False
 
'Запрет на действия Шаг3
Step3
'Запрет на действия Шаг4
Step4
'Запрет на действия Шаг5
Step5
bDBCreate = True
bNewStart = True
Exit Sub
 
ErrorHandler:
Select Case Err.Number
        'Пользователь нажал на Cancel CommonDialog
        Case 32755
        If bDBCreate = True Then
                'Разрешение на дальнейшие дествия Шаг2.
                Frame1.Enabled = True
                Command2.Enabled = True
                
                
        End If
        Exit Sub
        'Если БД уже существует
        Case 3204
        MsgBox "База Данных под этим именем уже существует." & _
                vbCrLf & "Введите новое имя для Базы Данных.", vbExclamation, _
                "Создание Баз Данных"
        Command1_Click
        Frame1.Enabled = False
        Exit Sub
        Case 91
        Resume Next
 
End Select
 
End Sub