13. Сообщение_f

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

Select Case KeyCode

Case vbKeyEscape

CloseObject acForm, Me.NAME

End Select

End Sub

Public Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)

SetLanguage Shift

End Sub

Private Sub Form_Open(Cancel As Integer)

Me![Label] = Nz(Me.OpenArgs, "")

End Sub

14. Сотрудники_на_обед_f

Private Sub Form_Open(Cancel As Integer)

Dim q() As String, i%

i = i + 1: ReDim Preserve q(1 To i) 'чистим уволенных сотрудников

q(i) = "DELETE [Объект физическое лицо].UVOLEN, Сотрудники_на_обеды.*" & vbNewLine

q(i) = q(i) & "FROM Сотрудники_на_обеды INNER JOIN " & vbNewLine

q(i) = q(i) & " [Объект физическое лицо] ON Сотрудники_на_обеды.KOD_FL = [Объект физическое лицо].ID_FIZICHESK_FACE" & vbNewLine

q(i) = q(i) & "WHERE [Объект физическое лицо].UVOLEN=True"

If Not ExecuteTrans("обновление", q) Then Exit Sub

End Sub

Private Sub Form_Resize()

StdResize Me![Сотрудники_на_обед_SF], Me

End Sub

15. Табель_f

Private Sub BUT_PRINT_Click()

DoCmd.OpenReport "Табель_R", acViewPreview

End Sub

Private Sub DATE_BEG_AfterUpdate()

If Me![DATE_BEG] > Me![DATE_END] Then Me![DATE_END] = Me![DATE_BEG] + 1

Me![Расчет_отработки_SF].Form.Requery

End Sub

Private Sub DATE_BEG_DblClick(Cancel As Integer)

OpenCalendar Me

Me![Расчет_отработки_SF].Form.Requery

End Sub

Private Sub DATE_END_AfterUpdate()

If Me![DATE_END] < Me![DATE_BEG] Then Me![DATE_BEG] = Me![DATE_END] - 1

Me![Расчет_отработки_SF].Form.Requery

End Sub

4. Модули

1. Attach_table

'Для работы данной программы в разделе [Libraries] файла MSACC20.INI

'должен быть указан модуль wizlib.mda.

Function TablesAttach() As Boolean

'Подключаем таблицы.

Dim TableCount As Integer, NRecs As Long, Mytable As TableDef

Dim MyTables As Recordset

Dim WorkDir As String, NameTable As String, NameFile As String

Dim NameLink_Table, f_IsItMde As Boolean, Connect As String

Dim mydb As Database

On Error GoTo ErrHandler

TablesAttach = False

f_IsItMde = IsItMDE()

'Блокируем свойства при запуске приложения .mde

SetProperties Not f_IsItMde

'устанавливаем свойство "Сжимать при закрытии"

CurrentDb.Properties("Auto Compact") = IIf(f_IsItMde, 0, 1)

Set mydb = CurrentDb

'Подключаем локальные таблицы

Set MyTables = mydb.OpenRecordset("Система_таблиц_локальных", dbOpenTable)

SysCmd acSysCmdInitMeter, "Подключение локальных таблиц ...", MyTables.RecordCount

MyTables.MoveFirst

TableCount = 1

Do Until MyTables.EOF

NameTable = Trim(MyTables!Name_table)

With mydb.TableDefs(NameTable)

.Connect = "MS Access;PWD=" & gPSW_BD & ";DATABASE=" & CurrentProject.Path & "\WorkPlace.mdb"

.RefreshLink

'Скрываем присоединенную таблицу в приложении .mde

If f_IsItMde Then .Attributes = dbHiddenObject

End With

MyTables.MoveNext

TableCount = TableCount + 1

SysCmd acSysCmdUpdateMeter, TableCount

Loop

MyTables.Close

SysCmd acSysCmdRemoveMeter

If DCount("WORK_DIR", gWORK_PLACE) = 0 Then CurrentDb.Execute "INSERT INTO " & gWORK_PLACE & " (KOD_PLACE, WORK_DIR, NUM_COMPUTER, NAME_COMPUTER, KOD_USER) SELECT nz(KOD_PLACE,0), ""z:"", NUM_COMPUTER, NAME_COMPUTER, nz(KOD_USER,0) FROM Настройка_раб_места "

'Подключаем внешние таблицы

Set MyTables = mydb.OpenRecordset("Система_таблиц", dbOpenTable)

'----------------------------------- Инициализация сообщения.

SysCmd acSysCmdInitMeter, "Подключение внешних таблиц для системы ...", MyTables.RecordCount

WorkDir = DLookup("[WORK_DIR]", gWORK_PLACE)

MyTables.MoveFirst

TableCount = 1

Do Until MyTables.EOF

NameTable = Trim(MyTables![Name_table])

NameLink_Table = Trim(MyTables![Name_link_table])

NameFile = Trim(MyTables![NAME_FILE])

'Удаление внешней таблицы

Connect = IIf(MyTables![PASSWD], "MS Access;PWD=" & gPSW_BD, "") & ";DATABASE=" & WorkDir & "\" & NameFile

With mydb.TableDefs(NameLink_Table)

If .Connect <> Connect Then

.Connect = Connect

.RefreshLink

End If

'Скрываем присоединенную таблицу в приложении .mde

If f_IsItMde Then .Attributes = dbHiddenObject

End With

MyTables.MoveNext

TableCount = TableCount + 1

SysCmd acSysCmdUpdateMeter, TableCount

Loop

MyTables.Close

SysCmd acSysCmdRemoveMeter

TablesAttach = True

Exit Function

ErrHandler:

Select Case Err

Case 3265 'Элемент не обнаружен в данном семействе.

Resume Next

Case 3044 'Строка '$' задает ошибочный путь. Проверьте, что путь задан правильно и имеется подключение к серверу, на котором находятся файлы.

MsgBox "Нет связи с основным компьютером или отсутствует база данных"

DoCmd.Quit

Case Else

ErrHandlerProc "Подключение таблиц", "Подключение таблиц"

Stop

Resume

End Select

Resume Next

End Function

2. Baza

Public Function polzovatel(KOD_MENU As Variant, Optional WARN As Boolean = False) As Boolean

polzovatel = False

If Not IsNull(KOD_MENU) Then

If Not DLookup("FOR_ALL", "Объект меню", "ID = " & KOD_MENU) Then

If IsNull(DLookup("KOD_PLACE", "Пользователи_права", _

"KOD_PLACE = " & DLookup("KOD_PLACE", gWORK_PLACE) & " AND " & _

"KOD_FL = " & DLookup("KOD_USER", gWORK_PLACE) & " AND KOD_MENU = " & KOD_MENU)) Then

If WARN Then MsgBox DLookup("NAIMEN", "Объект меню", "ID = " & KOD_MENU) & vbNewLine & vbNewLine & _

UserAllowedList(CLng(KOD_MENU), DLookup("KOD_PLACE", gWORK_PLACE)), vbCritical, _

PERMISION_DENIED_TITLE

Exit Function

End If

End If

End If

polzovatel = True

End Function

Public Function UserAllowedList(KOD_MENU As Long, Optional KOD_PLACE As Variant)

Dim s As String, rst As Recordset

If IsMissing(KOD_PLACE) Then KOD_PLACE = DLookup("KOD_PLACE", gWORK_PLACE)

Set rst = CurrentDb.OpenRecordset("SELECT DISTINCT FIO([FAMILIY],[NAME],[OTCHESTVO]) AS FL, " & _ "Пользователи_права.MODE " & _ "FROM (Пользователи_права INNER JOIN " & _ "[Объект физическое лицо] ON Пользователи_права.KOD_FL = [Объект физическое лицо].ID_FIZICHESK_FACE) INNER JOIN " & _ "[Объект размещение физлица] ON Пользователи_права.KOD_FL = [Объект размещение физлица].KOD_FL " & _

"WHERE Пользователи_права.KOD_PLACE=" & KOD_PLACE & " AND " & _ "Пользователи_права.KOD_FL<>874 AND " & _ "Пользователи_права.KOD_FL<>316 AND " & _"Пользователи_права.KOD_MENU=" & KOD_MENU & " AND " & _ "[Объект физическое лицо].UVOLEN = False AND " & _"[Объект размещение физлица].KOD_PLACE =" & KOD_PLACE & " AND " & _"[Объект размещение физлица].ACTIVE = True " & _ "ORDER BY FIO([FAMILIY],[NAME],[OTCHESTVO])")

While Not rst.EOF

s = s & IIf(s <> "", vbNewLine, "") & rst![FL] & IIf(rst![MODE], vbTab & "(адм)", "")

rst.MoveNext

Wend

rst.Close

UserAllowedList = IIf(s <> "", "Доступно следующим пользователям:" & vbNewLine, "") & s

End Function

3. rControlForm

Option Compare Database

Option Explicit

Private WithEvents frm As Form

Dim Ctrol(0 To 100) As New rCtrl 'массив контролов текстбоксов и комбобоксов

Private ctr As Control

Private KOD_MENU As Integer

Private USER As Integer

Private NUM_COMPUTER As Integer

Public Sub GetForm(gfrm As Form)

Dim i%

Set frm = gfrm

frm.OnLoad = "[Event Procedure]"

frm.OnClose = "[Event Procedure]"

frm.OnKeyUp = "[Event Procedure]"

frm.KeyPreview = True

For Each ctr In frm.Controls

'If frm.DefaultView = 0 Then

If frm.Controls(ctr.NAME).ControlType = acTextBox Or frm.Controls(ctr.NAME).ControlType = acComboBox Then

Set Ctrol(i) = New rCtrl

Ctrol(i).GetCtrl ctr

i = i + 1

End If

'End If

Next

End Sub

Private Sub frm_Close()

Dim query As String

query = "UPDATE Контроль_запущенных_программ INNER JOIN " & vbNewLine

query = query & "" & gWORK_PLACE & " ON (Контроль_запущенных_программ.NUM_COMPUTER = " & gWORK_PLACE & ".NUM_COMPUTER) AND " & vbNewLine query = query & " (Контроль_запущенных_программ.KOD_FL = " & gWORK_PLACE & ".KOD_USER) " & vbNewLine query = query & "SET Контроль_запущенных_программ.[DATE_END] = Now()" & vbNewLine query = query & "WHERE Контроль_запущенных_программ.KOD_MENU=" & KOD_MENU & vbNewLine

query = query & " AND Контроль_запущенных_программ.FORM_NAME='" & frm.NAME & "'"

CurrentDb.Execute query

End Sub

Private Sub frm_KeyUp(KeyCode As Integer, Shift As Integer)

SetLanguage Shift

End Sub

Private Sub frm_Load()

Dim query As String

KOD_MENU = Nz(DLookup("ID", "Объект меню", "OBJECT_NAME='" & frm.NAME & "'"), 0)

USER = DLookup("KOD_USER", gWORK_PLACE)

NUM_COMPUTER = DLookup("NUM_COMPUTER", gWORK_PLACE)

If IsNull(DLookup("KOD_FL", "Контроль_запущенных_программ", "NUM_COMPUTER=" & NUM_COMPUTER & " AND KOD_FL=" & USER & " AND FORM_NAME='" & frm.NAME & "' AND KOD_MENU=" & KOD_MENU)) Then

query = "INSERT INTO Контроль_запущенных_программ ( NUM_COMPUTER, KOD_FL, FORM_NAME, KOD_MENU, CAPTION, DATE_BEG )" & vbNewLine

query = query & "SELECT " & gWORK_PLACE & ".NUM_COMPUTER, " & vbNewLine

query = query & " " & gWORK_PLACE & ".KOD_USER, " & vbNewLine

query = query & " '" & frm.NAME & "', " & vbNewLine

query = query & " " & KOD_MENU & ", " & vbNewLine

query = query & " '" & CurrentDb.Properties!AppTitle & "', " & vbNewLine

query = query & " Now()" & vbNewLine

query = query & "FROM " & gWORK_PLACE

Else

query = "UPDATE Контроль_запущенных_программ INNER JOIN " & vbNewLine

query = query & "" & gWORK_PLACE & " ON (Контроль_запущенных_программ.NUM_COMPUTER = " & gWORK_PLACE & ".NUM_COMPUTER) AND " & vbNewLine

query = query & " (Контроль_запущенных_программ.KOD_FL = " & gWORK_PLACE & ".KOD_USER) " & vbNewLine

query = query & "SET Контроль_запущенных_программ.[DATE_BEG] = Now()," & vbNewLine

query = query & " Контроль_запущенных_программ.[CAPTION] = '" & CurrentDb.Properties!AppTitle & "'" & vbNewLine

query = query & "WHERE Контроль_запущенных_программ.KOD_MENU=" & KOD_MENU & vbNewLine

query = query & " AND Контроль_запущенных_программ.FORM_NAME='" & frm.NAME & "'"

End If

CurrentDb.Execute query

End Sub

4. rCtrl

Option Compare Database

Option Explicit

Private WithEvents ctrl As TextBox

Private WithEvents Combo As ComboBox

Public Sub GetCtrl(ct As Control)

Dim DV As Boolean

DV = (ct.Application.CodeContextObject.DefaultView = 0)

If ct.ControlType = acComboBox Then

Set Combo = ct

Combo.OnDblClick = "[Event Procedure]"

End If

If ct.ControlType = acTextBox Then

Set ctrl = ct

ctrl.OnDblClick = "[Event Procedure]"

End If

'если форма обычная то включаем обработку событий

If DV Then

If ct.ControlType = acComboBox Then

Combo.OnGotFocus = "[Event Procedure]"

Combo.OnLostFocus = "[Event Procedure]"

End If

If ct.ControlType = acTextBox Then

ctrl.OnGotFocus = "[Event Procedure]"

ctrl.OnLostFocus = "[Event Procedure]"

End If

End If

End Sub

Private Sub Combo_GotFocus()

Combo.BackColor = MyColor.vbPaleGreen

End Sub

Private Sub Combo_LostFocus()

Combo.BackColor = vbWhite

End Sub

Private Sub Ctrl_DblClick(Cancel As Integer)

If (ctrl.Format = "Short Date" Or ctrl.Format = "dd/mm/yy") And Not ctrl.Locked Then

OpenCalendar ctrl.Application.CodeContextObject

SelectAfterUpdate ctrl

End If

End Sub

Private Sub Combo_DblClick(Cancel As Integer)

If (Combo.Format = "Short Date" Or Combo.Format = "dd/mm/yy") And Not Combo.Locked And Not Combo.LimitToList Then

OpenCalendar Combo.Parent

SelectAfterUpdate Combo

End If

End Sub

Private Sub Ctrl_GotFocus()

ctrl.BackColor = MyColor.vbPaleGreen

End Sub

Private Sub Ctrl_LostFocus()

ctrl.BackColor = vbWhite

End Sub

Private Sub SelectAfterUpdate(tctrl As Object)

Dim canl As Integer

If Equal(tctrl.value, tctrl.OldValue) Then Exit Sub

On Error Resume Next

CallByName Forms(tctrl.Parent.NAME), tctrl.EventProcPrefix & "_BeforeUpdate", VbMethod, canl

If Not canl Then CallByName Forms(tctrl.Parent.NAME), tctrl.EventProcPrefix & "_AfterUpdate", VbMethod

End Sub