Заполнение элементов 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

 

Приложение Д - Иллюстрационный материал