9. Настройки программ

Public Sub CreateTimeTable(FormName As String)

Dim rstt As Recordset, NewTbl As TableDef, db As Database

Dim SQLstr As String, INTOstr As String, VALUEstr As String

Set db = CurrentDb

SQLstr = "SELECT Настройки_программ.FIELD_NAME, Настройки_программ.FIELD_VALUE, Настройки_программ.FIELD_TYPE " & _

"FROM Объект_программы INNER JOIN " & _

"Настройки_программ ON Объект_программы.ID = Настройки_программ.KOD_FORM " & _

"WHERE Объект_программы.FORM_NAME=" & Quoted(FormName)

Set rstt = db.OpenRecordset(SQLstr) 'получаем список полей для формы

If rstt.RecordCount > 0 Then Set NewTbl = db.CreateTableDef("Т_" & FormName) 'создаем новую временую таблицу с названием формы

While Not rstt.EOF 'создаем поля

NewTbl.Fields.Append NewTbl.CreateField(rstt![FIELD_NAME], rstt![FIELD_TYPE])

INTOstr = INTOstr & IIf(INTOstr <> "", ", ", "") & rstt![FIELD_NAME] 'собираем названия полей

VALUEstr = VALUEstr & IIf(VALUEstr <> "", ", ", "") & TypeChoose(rstt![FIELD_TYPE], Nz(rstt![FIELD_VALUE], "Null")) 'собираем значения полей

rstt.MoveNext

Wend

rstt.Close

If INTOstr <> "" Then

db.TableDefs.Append NewTbl 'формируем готовую табилцу

SQLstr = "INSERT INTO [Т_" & FormName & "] (" & INTOstr & ")" & _

"SELECT " & VALUEstr

db.Execute SQLstr 'вставляем значения в таблицу

End If

db.Close

End Sub

Private Function TypeChoose(Tp As Integer, valF As String) As String

If valF = "Null" Then TypeChoose = valF: Exit Function

Select Case Tp

Case 1, 2, 3, 4, 5, 6, 7:

TypeChoose = valF

Case 8

If valF = "Date()" Or valF = "Now()" Then

TypeChoose = valF

Else

TypeChoose = SQL_date(valF)

End If

Case 10, 12

TypeChoose = Quoted(valF)

Case Else

TypeChoose = valF

End Select

End Function

Public Function IsTable(NameTable As String) As Boolean

On Error Resume Next: IsTable = (CurrentDb.TableDefs(NameTable).NAME = NameTable): On Error GoTo ErrHandler

Exit Function

ErrHandler: IsTable = False

Exit Function

End Function

10. Создание нового модуля

Public Function CreateNewModule() As Boolean

Dim NewFile As String, i%

Dim db As Database

Dim app As Application

Dim ref As Reference, mref As Reference

CreateNewModule = False

NewFile = "Employee_.mdb"

For i = 0 To Forms.Count - 1

CloseObject acForm, Forms(0).NAME, , True

Next

On Error Resume Next: Kill NewFile: On Error GoTo 0

DBEngine.CreateDatabase NewFile, dbLangCyrillic, dbVersion40

Set db = CurrentDb

Debug.Print "происходит экспорт:"

'импорт таблиц

For i = 0 To db.TableDefs.Count - 1

If db.TableDefs(i).Attributes = 0 Or db.TableDefs(i).Attributes = 1073741824 Then DoCmd.CopyObject NewFile, db.TableDefs(i).NAME, acTable, db.TableDefs(i).NAME

Next

Debug.Print "таблиц"

'импорт запросов

For i = 0 To db.QueryDefs.Count - 1

DoCmd.CopyObject NewFile, db.QueryDefs(i).NAME, acQuery, db.QueryDefs(i).NAME

Next

Debug.Print i + 1, "запросов"

db.Close

'импорт модулей

For i = 0 To CurrentProject.AllModules.Count - 1

DoCmd.CopyObject NewFile, CurrentProject.AllModules(i).NAME, acModule, CurrentProject.AllModules(i).NAME

Next

Debug.Print i + 1, "модулей"

'импорт форм

For i = 0 To CurrentProject.AllForms.Count - 1

DoCmd.CopyObject NewFile, CurrentProject.AllForms(i).NAME, acForm, CurrentProject.AllForms(i).NAME

Next

Debug.Print i + 1, "форм"

'импорт форм

For i = 0 To CurrentProject.AllMacros.Count - 1

DoCmd.CopyObject NewFile, CurrentProject.AllMacros(i).NAME, acMacro, CurrentProject.AllMacros(i).NAME

Next

Debug.Print i + 1, "макросов"

'импорт отчетов

For i = 0 To CurrentProject.AllReports.Count - 1

DoCmd.CopyObject NewFile, CurrentProject.AllReports(i).NAME, acReport, CurrentProject.AllReports(i).NAME

Next

Debug.Print i + 1, "отчетов"

Debug.Print "Экспорт завершен!"

'создаем свойство

Set app = CreateObject("access.Application")

'подключаем нужный файл

app.OpenCurrentDatabase CurrentProject.Path & "\" & NewFile 'файл КУДА копируем референсы из текущего

'в ссылках текущего проета

Debug.Print "удаляем референсы"

For i = 0 To app.References.Count - 3

app.References.Remove app.References.Item(app.References.Count) ' удаляем все ненужные ссылки

Next

Debug.Print "добавляем новые референсы из текущей базы:"

For Each ref In Application.References

Debug.Print ref.NAME, ref.FullPath, ref.Major 'выводим ссылки

For Each mref In app.References 'в ссылках другого файла

If mref.NAME = ref.NAME Then GoTo 1 'если совпадают, пропускаем

Next

app.References.AddFromFile ref.FullPath 'добавляем ссылку

1: Next

Debug.Print "Ссылки установлены"

'app.Application.CommandBars.Add "Вход"

'app.Application.CommandBars ("Вход")

'app.MenuBar = "Вход" 'Сервис->Параметры запуска...->Строка меню

app.CurrentDb.Properties.Append app.CurrentDb.CreateProperty("StartUpForm", 10, "Вход_F") 'вход при запуске

Debug.Print "Форма Вход_F при входе"

app.CurrentDb.Properties.Append app.CurrentDb.CreateProperty("Auto Compact", 1, True) 'сжимать при закрытии

Debug.Print "парамерт сжимать при закрытии"

app.CurrentDb.Properties.Append app.CurrentDb.CreateProperty("AppTitle", 10, "Учет рабочего времени") 'заголовок приложения

Debug.Print "Установка заголовка приложения"

If NewFile = "Employee" Then

app.CurrentDb.Properties.Append app.CurrentDb.CreateProperty("AppIcon", 10, "Z:\bd_sklad\employee.ico") 'иконка приложения

Debug.Print "иконка"

End If

app.CurrentDb.Properties.Append app.CurrentDb.CreateProperty("StartUpShowDBWindow", 1, False) 'не показывать базу данных при входе

app.CloseCurrentDatabase 'закрываем базу

CreateNewModule = True

MsgBox "Новый файл создан: " & NewFile & vbNewLine & "Зайдите в него с нажатием клавиши SHIFT и произведите импорт меню, панелей, спецификаций и схемы данных", vbInformation, "Успешно выполнено"

'Debug.Print db.TableDefs(i).Name & db.TableDefs(i).Attributes

'DoCmd.TransferDatabase acImport, , NewFile, acTable + acModule + acQuery + acReport + acForm, File

End Function