Заполнение элементов ActiveX
Public Function Init_ListView(OBJ As Object, SQL_str As String, Optional coloring As Boolean = False, Optional zagl As Integer = 0) As Integer
Dim rs As Recordset
Dim db As Database
Dim lstItem As ListItem
Dim n%, R%, G%, B%
With OBJ
'Set ListView style
.View = lvwReport
'This is not supported by ListView 5
.Gridlines = True
.FullRowSelect = True
'Clear Header and ListItems
.ListItems.Clear
.ColumnHeaders.Clear
Set db = CurrentDb()
Set rs = db.OpenRecordset(SQL_str)
If rs.RecordCount = 0 Then Exit Function
For n = 1 To rs.Fields.Count - 1
.ColumnHeaders.Add , , rs(n).NAME, IIf(Len(rs(n).NAME) < Len(rs(n)), Len(rs(n)), Len(rs(n).NAME)) * 100 + 400, lvwColumnLeft
Next
End With
rs.MoveFirst
Do Until rs.EOF
Set lstItem = OBJ.ListItems.Add()
lstItem.Text = rs(1)
lstItem.key = "k" & rs(0)
If rs.AbsolutePosition = 0 And zagl = 1 Then
lstItem.Bold = True
End If
If rs.AbsolutePosition = rs.RecordCount - 1 And zagl = 2 Then
lstItem.Bold = True
End If
If coloring Then
colorlist R, G, B
lstItem.ForeColor = rgb(R, G, B)
End If
For n = 2 To rs.Fields.Count - 1
lstItem.SubItems(n - 1) = Nz(rs(n))
If rs.AbsolutePosition = 0 And zagl = 1 Then
lstItem.ListSubItems(n - 1).Bold = True
End If
If rs.AbsolutePosition = rs.RecordCount - 1 And zagl = 2 Then
lstItem.ListSubItems(n - 1).Bold = True
End If
If coloring Then
colorlist R, G, B
lstItem.ListSubItems(n - 1).ForeColor = rgb(R, G, B)
End If
Next
rs.MoveNext
Loop
Init_ListView = rs.RecordCount
rs.Close
End Function
Изменение размеров форм
Public Sub StdResize(frm As Object, pfrm As Form)
Dim HOLE As Integer
HOLE = 110
With frm
If pfrm.InsideHeight < .Top + HOLE Then pfrm.InsideHeight = .Top - HOLE
If pfrm.InsideHeight > .Top + pfrm.Section(acFooter).HEIGHT + pfrm.Section(acHeader).HEIGHT + HOLE Then .HEIGHT = pfrm.InsideHeight - .Top - pfrm.Section(acFooter).HEIGHT - pfrm.Section(acHeader).HEIGHT - HOLE
If pfrm.InsideWidth > .Left + HOLE Then .WIDTH = pfrm.InsideWidth - .Left - HOLE
End With
End Sub
Календарь
Option Compare Database
Option Explicit
Public Const SWP_NOZORDER = &H4
Public Type gRect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type Dimensions
Width As Long
HEIGHT As Long
End Type
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Declare Function GetFocus Lib "user32" () As Long
Public Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, lpRect As gRect) As Long
Public Function ControlRect(ctl As Control) As gRect
ctl.SetFocus
GetWindowRect GetFocus(), ControlRect
End Function
Public Function FormDimensions(frm As Form) As Dimensions
Dim frmRect As gRect
GetWindowRect frm.hwnd, frmRect
FormDimensions.Width = frmRect.Right - frmRect.Left
FormDimensions.HEIGHT = frmRect.Bottom - frmRect.Top
End Function
Public Sub OpenCalendar(frm As Object)
OpenForm "Календарь_F", , , , , acHidden
Forms("Календарь_F").LastDate = frm.ActiveControl
Forms("Календарь_F").VISIBLE = True
While IsLoaded("Календарь_F"): DoEvents: Wend
End Sub
Настройки программ
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
Создание нового модуля
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
Приложение Д - Иллюстрационный материал