ИгортанИгортан,
До кучи, реально используемый модуль для ленты
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
Option Compare Database
Option Explicit
Public myrib As IRibbonUI
'---------------------------------------------------------------------------------------
' Procedure : CreateRibbon
' Purpose : присваивание ленты USysRibbonsReady
'---------------------------------------------------------------------------------------
'
Function CreateRibbon()
Dim MyRecRibbons As DAO.Recordset
On Error GoTo CreateRibbon_Error
Set MyRecRibbons = CurrentDb.OpenRecordset("SELECT * FROM USysRibbons WHERE Namber_Version>=" & Application_Version & "")
If Not MyRecRibbons.EOF Then
MyRecRibbons.Edit
If Developer = True Then
MyRecRibbons!RibbonBody = Replace(MyRecRibbons!RibbonBody, "<ribbon startFromScratch= >", "<ribbon startFromScratch=""false"" >")
MyRecRibbons!RibbonBody = Replace(MyRecRibbons!RibbonBody, "<ribbon startFromScratch=""true"" >", "<ribbon startFromScratch=""false"" >")
MyRecRibbons!RibbonBody = Replace(MyRecRibbons!RibbonBody, "<ribbon startFromScratch=""true"">", "<ribbon startFromScratch=""false"" >")
Else
MyRecRibbons!RibbonBody = Replace(MyRecRibbons!RibbonBody, "<ribbon startFromScratch= >", "<ribbon startFromScratch=""true"" >")
MyRecRibbons!RibbonBody = Replace(MyRecRibbons!RibbonBody, "<ribbon startFromScratch=""false"" >", "<ribbon startFromScratch=""true"" >")
MyRecRibbons!RibbonBody = Replace(MyRecRibbons!RibbonBody, "<ribbon startFromScratch=""false"">", "<ribbon startFromScratch=""true"" >")
End If
MyRecRibbons.Update
Application.LoadCustomUI MyRecRibbons!RibbonName, MyRecRibbons!RibbonBody
Else
If Application_Version = 12 Then
Application.LoadCustomUI "MyRibbon", "<customUI xmlns=""http://schemas.microsoft.com/office/2006/01/customui"" onLoad=""MyRibbonLoad""> <ribbon startFromScratch=""false""> </ribbon> </customUI>"
ElseIf Application_Version >= 14 Then
Application.LoadCustomUI "MyRibbon", "<customUI xmlns=""http://schemas.microsoft.com/office/2009/07/customui"" onLoad=""MyRibbonLoad""> <ribbon startFromScratch=""false""> </ribbon> </customUI>"
Else
GoTo CreateRibbon_Error
End If
' ' открытие ленты
' DoCmd.ShowToolbar "Ribbon", acToolbarYes
End If
' Debug.Print MyRecRibbons!RibbonBody
MyRecRibbons.Close
Set MyRecRibbons = Nothing
On Error GoTo 0
Exit Function
CreateRibbon_Error:
MsgBox "Ошибка создания ленты программы! Проверьте правильный адрес файла данных.", , "Критическая ошибка(" & Err.Number & ")!"
Call Outputs
End Function
Public Function MyRibbonLoad(ByRef tRibbonUI As IRibbonUI)
'MsgBox "инициирована"
Set myrib = tRibbonUI
End Function
Public Function GroupMainOnActionCallBack()
' открытие ленты
DoCmd.ShowToolbar "Ribbon", acToolbarYes
myrib.Invalidate
End Function
'---------------------------------------------------------------------------------------
' Procedure : Application_Version
' Purpose : определяем текущую версию Access
'---------------------------------------------------------------------------------------
'
Public Function Application_Version() As Long
On Error Resume Next
Application_Version = CLng(Nz(Left([Application].[Version], 2), 14))
End Function
'---------------------------------------------------------------------------------------
' Procedure : getVisible
' Author : IHAR
' Purpose : ОТРАБОТКА ВИДИМОСТИ КОНТРОЛОВ ДЛЯ КОНКРЕТНОГО ТИПА ЮЗЕРА
'---------------------------------------------------------------------------------------
'
Public Function getVisible(Control As IRibbonControl, ByRef blVisibleVal)
On Error Resume Next
'On Error GoTo getVisible_Error
blVisibleVal = CBool(Nz(DLookup("Temp_Visible", "UsysSettingUserRibbon", "Id=""" & Control.Id & """"), 0))
On Error GoTo 0
Exit Function
getVisible_Error:
blVisibleVal = False
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure getVisible of Module Usys_Main_Function_Rib"
End Function
'---------------------------------------------------------------------------------------
' Procedure : AccessButtons
' Author : Igor
' Purpose : общая функция для изменения видимости кнопок в зависиимости от ситуации
'---------------------------------------------------------------------------------------
'
Public Sub getVisibleControls(lngTypeWork As Long, Optional strContr As String = "Tb36")
'lngTypeWork -тип работы:0=дефолтное, 1=закрываем, 2=открываем
'strContr - поиск контрола по id. Для старта форм - id приходит из ленты в параметрах функции
Dim er As Long ', n As String
Dim strMy As DAO.Recordset
On Error Resume Next 'On Error GoTo AccessButtons_Error
er = 1
Set strMy = CurrentDb.OpenRecordset("SELECT * FROM UsysSettingUserRibbon WHERE ((Id)=""" & strContr & """)")
If Not strMy.EOF Then
er = 2
strMy.Edit
If lngTypeWork = 0 Then
strMy!Temp_Visible = strMy!Temp_VisibleDef
ElseIf lngTypeWork > 0 Then
strMy!Temp_Visible = lngTypeWork - 1
End If
strMy.Update
' n = strMy!id
End If
strMy.Close
If Not strMy Is Nothing Then Set strMy = Nothing
er = 3
myrib.InvalidateControl strContr
On Error GoTo 0
Exit Sub
AccessButtons_Error:
If Not strMy Is Nothing Then Set strMy = Nothing
If er = 1 Then
MsgBox "Ошибка установки параметров доступа к функциям", , "Внимание!"
ElseIf er = 2 Then
MsgBox "Ошибка задания параметров доступа к функциям", , "Внимание!"
ElseIf er = 3 Then
MsgBox "ошибка обновления параметров доступа к функциям", , "Внимание!"
Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure AccessButtons of Form_OrdersLink"
End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure : getEnabled
' Author : IHAR
' Purpose : ОТРАБОТКА ДОСТУПНОСТИ КОНТРОЛОВ ДЛЯ КОНКРЕТНОГО ТИПА ЮЗЕРА
'---------------------------------------------------------------------------------------
'
Public Function getEnabled(Control As IRibbonControl, ByRef blVisibleVal)
On Error Resume Next 'GoTo GetEnabledControls_Error
blVisibleVal = CBool(Nz(DLookup("Temp_Enabled", "UsysSettingUserRibbon", "Id=""" & Control.Id & """"), 0))
On Error GoTo 0
Exit Function
GetEnabledControls_Error:
blVisibleVal = False
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure GetEnabledControls of Module Usys_Main_Function_Rib"
End Function
'---------------------------------------------------------------------------------------
' Procedure : AccessButtons
' Author : Igor
' Purpose : общая функция для изменения видимости кнопок в зависиимости от ситуации
'---------------------------------------------------------------------------------------
'
Public Sub getEnabledControls(lngTypeWork As Long, Optional strContr As String = "Tb36")
'lngTypeWork -тип работы:0=дефолтное, 1=закрываем, 2=открываем
'strContr - поиск контрола по id. Для старта форм - id приходит из ленты в параметрах функции
Dim er As Long ', n As String
Dim strMy As DAO.Recordset
On Error Resume Next '
On Error GoTo AccessButtons_Error
er = 1
Set strMy = CurrentDb.OpenRecordset("SELECT * FROM UsysSettingUserRibbon WHERE ((Id)=""" & strContr & """)")
If Not strMy.EOF Then
er = 2
strMy.Edit
If lngTypeWork = 0 Then
strMy!Temp_Enabled = strMy!Temp_EnabledDef
ElseIf lngTypeWork > 0 Then
strMy!Temp_Enabled = lngTypeWork - 1
End If
strMy.Update
' n = strMy!id
End If
strMy.Close
If Not strMy Is Nothing Then Set strMy = Nothing
er = 3
myrib.InvalidateControl strContr
On Error GoTo 0
Exit Sub
AccessButtons_Error:
If Not strMy Is Nothing Then Set strMy = Nothing
If er = 1 Then
MsgBox "Ошибка установки параметров доступа к функциям", , "Внимание!"
ElseIf er = 2 Then
MsgBox "Ошибка задания параметров доступа к функциям", , "Внимание!"
ElseIf er = 3 Then
MsgBox "ошибка обновления параметров доступа к функциям", , "Внимание!"
Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure AccessButtons of Form_OrdersLink"
End If
End Sub
''''---------------------------------------------------------------------------------------
'''' Procedure : getSupertip
'''' Author : IHAR
'''' Purpose : выпадающая подсказка при наведении(comment)
''''---------------------------------------------------------------------------------------
''''
'''Function getSupertip(Control As IRibbonControl, ByRef Supertip)
'''Dim Id_Controls As Long
'''Dim MyRec As DAO.Recordset
'''
''' On Error GoTo GetSupertip_Error
'''
''''Id_Controls = right(Control.id, Len(Control.id) - 2)
''''
''''Set MyRec = CurrentDb.OpenRecordset("SELECT DISTINCT Property_Value FROM Usys_Ribbon_Controls INNER JOIN (Usys_Ribbon_Control_Propertys INNER JOIN Usys_Ribbon_Control_Type_Propertys ON Usys_Ribbon_Control_Propertys.Id_Property = Usys_Ribbon_Control_Type_Propertys.Property_Type) ON Usys_Ribbon_Controls.Id_Control = Usys_Ribbon_Control_Type_Propertys.Control " & _
'''' "WHERE (((Control)=" & Id_Controls & ") AND ((Type_Control)=[Temp_Type]) AND ((Name_Property)=""getSupertip""))")
''''If Not MyRec.EOF Then
'''' Supertip = MyRec!Property_Value
''''Else
''' Supertip = ""
''''End If
''''
''''Set MyRec = Nothing
'''
''' On Error GoTo 0
''' Exit Function
'''
'''GetSupertip_Error:
'''If Not MyRec Is Nothing Then Set MyRec = Nothing
''' MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure GetSupertip of Module Usys_Main_Function_Rib"
'''End Function
'''
''''---------------------------------------------------------------------------------------
'''' Procedure : getScreentip
'''' Author : IHAR
'''' Purpose : название выпадающей подсказки при наведении(comment)
''''---------------------------------------------------------------------------------------
''''
'''Function getScreentip(Control As IRibbonControl, ByRef Supertip)
'''Dim Id_Controls As Long
'''Dim MyRec As DAO.Recordset
'''
''' On Error GoTo GetScreentip_Error
'''
''''Id_Controls = right(Control.id, Len(Control.id) - 2)
''''
''''Set MyRec = CurrentDb.OpenRecordset("SELECT DISTINCT Property_Value FROM Usys_Ribbon_Controls INNER JOIN (Usys_Ribbon_Control_Propertys INNER JOIN Usys_Ribbon_Control_Type_Propertys ON Usys_Ribbon_Control_Propertys.Id_Property = Usys_Ribbon_Control_Type_Propertys.Property_Type) ON Usys_Ribbon_Controls.Id_Control = Usys_Ribbon_Control_Type_Propertys.Control " & _
'''' "WHERE (((Control)=" & Id_Controls & ") AND ((Type_Control)=[Temp_Type]) AND ((Name_Property)=""getScreentip""))")
''''If Not MyRec.EOF Then
'''' Supertip = MyRec!Property_Value
''''Else
''' Supertip = ""
''''End If
''''
''''Set MyRec = Nothing
'''
''' On Error GoTo 0
''' Exit Function
'''
'''GetScreentip_Error:
'''If Not MyRec Is Nothing Then Set MyRec = Nothing
''' MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure GetScreentip of Module Usys_Main_Function_Rib"
'''End Function
'---------------------------------------------------------------------------------------
' Procedure : getLabel
' Author : IHAR
' Purpose : УСТАНОВКА НАЗВАНИЙ(ПОДПИСЕЙ) КОНТРОЛОВ
'---------------------------------------------------------------------------------------
'
Public Sub getLabel(Control As IRibbonControl, ByRef label)
On Error Resume Next 'GoTo GetNameInset_Error
label = Nz(DLookup("NameControl", "UsysSettingUserRibbon", "Id=""" & Control.Id & """"), "NOTHING")
'Debug.Print Control.id, label
On Error GoTo 0
Exit Sub
GetNameInset_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure GetNameInset of Module Usys_Main_Function_Rib"
End Sub
'---------------------------------------------------------------------------------------
' Procedure : NameButtons
' Author : Igor
' Purpose : общая функция для изменения названий контролов ленты для опред. ситуаций
'---------------------------------------------------------------------------------------
'
Public Sub NameButtons(strName As String, strButt As String)
Dim er As Long
On Error Resume Next 'GoTo AccessButtons_Error
er = 2
'формирование временных данных для контекстной вкладки
CurrentProject.Connection.Execute ("UPDATE UsysSettingUserRibbon SET NameControl = """ & strName & """ WHERE (((Id) =""" & strButt & """))")
er = 3
myrib.InvalidateControl strButt
On Error GoTo 0
Exit Sub
AccessButtons_Error:
If er = 1 Then
MsgBox "Ошибка установки параметров доступа к функциям", , "Внимание!"
ElseIf er = 2 Then
MsgBox "Ошибка задания параметров доступа к функциям", , "Внимание!"
ElseIf er = 3 Then
MsgBox "ошибка обновления параметров доступа к функциям", , "Внимание!"
Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure AccessButtons of Form_OrdersLink"
End If
End Sub
и модуль для вызова функций. Сюда направляются все вызовы. С ленты, кнопок, контекстного меню.
Для универсальности.
Из развивающегося проекта
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
337.
338.
339.
340.
341.
342.
343.
344.
345.
346.
347.
348.
349.
350.
351.
352.
353.
354.
355.
356.
357.
358.
359.
360.
361.
362.
363.
364.
365.
366.
367.
368.
369.
370.
371.
372.
373.
374.
375.
376.
377.
378.
379.
380.
381.
382.
383.
384.
385.
386.
387.
388.
389.
390.
391.
392.
393.
394.
395.
396.
397.
398.
399.
400.
401.
402.
403.
404.
405.
Option Compare Database
Option Explicit
Public MyCountFrm As Long
Private NameActFrm As String
Private MyActiveReport As Report
Private MyActiveForm As Form
Public Function Calc()
Dim WshShell As Object
Dim stAppName As String
On Error GoTo Calc_Error
stAppName = "%WINDIR%\System32\"
' Создаем ссылку на объект WscriptShell
Set WshShell = CreateObject("WScript.Shell")
WshShell.Run stAppName & "calc.exe", 1, False
On Error GoTo 0
Exit Function
Calc_Error:
' If LogError(Err.Number, Err.Description, Erl, "Calc", "Load", "") = True Then
' Call ErrorLogFunct
' Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Calc of Load", , "Error!"
' End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : OpenMyForm
' Author : IHAR
' Purpose : открытие формы
'---------------------------------------------------------------------------------------
Public Function OpenMyForm(NameForm As String, Optional MyContr As String = "") As Boolean
On Error GoTo OpenMyForm_Error
If IsFormLoaded(NameForm) = False Then
DoCmd.OpenForm NameForm, acNormal, , , acFormEdit, acWindowNormal, MyContr
Else
DoCmd.Echo False
DoCmd.Close acForm, NameForm, acSaveNo
DoCmd.OpenForm NameForm, acNormal, , , acFormEdit, acWindowNormal, MyContr
DoCmd.Echo True
End If
On Error GoTo 0
Exit Function
OpenMyForm_Error:
DoCmd.Echo True
If Err.Number <> 0 And Err.Number <> 2501 Then
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure OpenMyForm of Usys_Main_Function_Rib", , "Error!"
End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : AboutF
' Author : IHAR
' Purpose : Выход из приложения
'---------------------------------------------------------------------------------------
Public Function OutputDB()
On Error Resume Next
DoCmd.Close acForm, "Password_entry"
End Function
'---------------------------------------------------------------------------------------
' Procedure : CloseActiveForm
' Author : IHAR
' Purpose : закрытие активной формы
'---------------------------------------------------------------------------------------
Public Function CloseActiveForm()
Dim i As Long
Dim MyHwnd As Long
On Error GoTo CloseActiveForm_Error
MyHwnd = 0
NameActFrm = MyScreenActFrm(1, , MyHwnd)
If Right(NameActFrm, 3) = "All" Then
Forms(NameActFrm).MyCloseActiveForm
Else
Do While i < Forms.Count ' проверка всех форм и их id
If Forms.Item(i).Name = NameActFrm Then
If Forms.Item(i).Hwnd = MyHwnd Then
Call Forms.Item(i).MyCloseActiveForm
Exit Function
End If
End If
i = i + 1
Loop
End If
On Error GoTo 0
Exit Function
CloseActiveForm_Error:
If Err.Number = 0 And Err.Number = 2501 Then
Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure CloseActiveForm of Usys_Main_Function_Rib", , "Error!"
End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : ApplyFilter
' Author : IHAR
' Purpose : применить фильтр для вызывающей формы
'---------------------------------------------------------------------------------------
Public Function ApplyFilter() As Boolean
On Error GoTo ApplyFilter_Error
NameActFrm = MyScreenActFrm(1)
Set MyActiveForm = Forms(NameActFrm)
'
With MyActiveForm.Form
If .Dirty = True Then .Dirty = False
If NameActFrm <> "SettingAll" Then
With !sub_form.Form.MyClsSub
.setFilterOn = True
.myWhere (1)
End With
Else
.Form.ApplyFilter
End If
End With
If Not MyActiveForm Is Nothing Then Set MyActiveForm = Nothing
On Error GoTo 0
Exit Function
ApplyFilter_Error:
If Not MyActiveForm Is Nothing Then Set MyActiveForm = Nothing
MsgBox "ПРИМЕНИТЬ ФИЛЬТР " & NameActFrm
End Function
'---------------------------------------------------------------------------------------
' Procedure : ShowAll
' Author : IHAR
' Purpose : снять фильтр с вызывающей формы
'---------------------------------------------------------------------------------------
Public Function ShowAll() As Boolean
On Error GoTo ShowAll_Error
NameActFrm = MyScreenActFrm(1)
Set MyActiveForm = Forms(NameActFrm)
'
With MyActiveForm.Form
If .Dirty = True Then .Dirty = False
If NameActFrm <> "SettingAll" Then
!sub_form.Form.MyClsSub.setFilterOn = False
!sub_form.Form.MyClsSub.myWhere (0)
Else
.Form.ShowAll
End If
End With
If Not MyActiveForm Is Nothing Then Set MyActiveForm = Nothing
On Error GoTo 0
Exit Function
ShowAll_Error:
If Not MyActiveForm Is Nothing Then Set MyActiveForm = Nothing
MsgBox "ПОКАЗАТЬ ВСЕ " & NameActFrm
End Function
'---------------------------------------------------------------------------------------
' Procedure : RequeryTab
' Author : IHAR
' Purpose : обновление таблички вызывающей формы
'---------------------------------------------------------------------------------------
Public Function RequeryTab() As Boolean
On Error GoTo RequeryTab_Error
NameActFrm = MyScreenActFrm(1)
If Right(NameActFrm, 3) = "All" Then
If NameActFrm <> "SettingAll" Then
Forms(NameActFrm).sub_form.Form.MyClsSub.CmdRecLine
Else
Call Forms(NameActFrm).CmdRecLine
End If
End If
' Forms(NameActFrm)(NameActFrm & "_sub").Form.MyClsSub.CmdRecLine
On Error GoTo 0
Exit Function
RequeryTab_Error:
If Err.Number <> 0 And Err.Number <> 2501 Then
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure RequeryTab of Main_Function_Rib", , "Error!"
End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : AddLine
' Author : IHAR
' Purpose : добавить данные для вызывающей таблицы Control As IRibbonControl
'---------------------------------------------------------------------------------------
Public Function AddLine() As Boolean
On Error GoTo AddLine_Error
NameActFrm = MyScreenActFrm(1)
If Right(NameActFrm, 3) <> "All" Then
MsgBox "Open: " & NameActFrm
Else
If NameActFrm <> "SettingAll" Then
Forms(NameActFrm).sub_form.Form.MyClsSub.CmdAddLine
Else
Call Forms(NameActFrm).CmdAddLine
End If
End If
On Error GoTo 0
Exit Function
AddLine_Error:
If Err.Number <> 0 And Err.Number <> 2501 Then
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure AddLine of Main_Function_Rib", , "Error!"
End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : EditLine
' Author : IHAR
' Purpose : изменить данные из вызывающей формы
'---------------------------------------------------------------------------------------
Public Function EditLine() As Boolean
On Error GoTo EditLine_Error
NameActFrm = MyScreenActFrm(1)
If Right(NameActFrm, 3) = "All" Then
If NameActFrm <> "SettingAll" Then
Forms(NameActFrm).sub_form.Form.MyClsSub.CmdEditLine
Else
Call Forms(NameActFrm).CmdEditLine
End If
End If
On Error GoTo 0
Exit Function
EditLine_Error:
If Err.Number <> 0 And Err.Number <> 2501 Then
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure EditLine of Main_Function_Rib", , "Error!"
End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : DelLine
' Author : IHAR
' Purpose : удалить строку из вызывающей формы
'---------------------------------------------------------------------------------------
Public Function DelLine() As Boolean
On Error GoTo DelLine_Error
NameActFrm = MyScreenActFrm(1)
If Right(NameActFrm, 3) = "All" Then
If NameActFrm <> "SettingAll" Then
Forms(NameActFrm).sub_form.Form.MyClsSub.CmdDelLine
Else
Call Forms(NameActFrm).CmdDelLine
End If
End If
On Error GoTo 0
Exit Function
DelLine_Error:
If Err.Number <> 0 And Err.Number <> 2501 Then
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure DelLine of Main_Function_Rib", , "Error!"
End If
End Function
Public Function SendData() As Boolean
Forms!MainAll!sub_form.Form.MyClsSub.SendMail
End Function
Public Function MainReport() As Boolean
MsgBox "ВыводОтчетаОсновного"
' call OpenMyForm(NameForm As String)
End Function
Public Function MainReportEx() As Boolean
MsgBox "ЭкспортОтчетаОсновного"
' call OpenMyForm(NameForm As String, Optional MyContr As String = "")
End Function
Public Function WorkerReport() As Boolean
' MsgBox "ВыводОтчетаПоРаботникам"
Call OpenMyForm("ReportSearch", "ReporWorker")
End Function
Public Function WorkerReportEx() As Boolean
' MsgBox "ЭкспортОтчетаПоРаботникам"
Call OpenMyForm("ReportSearchExp", "ReporWorker")
End Function
Public Function CustomerReport() As Boolean
MsgBox "ВыводОтчетаПоКлиентам"
' call OpenMyForm(NameForm As String, Optional MyContr As String = "")
End Function
Public Function CustomerReportEx() As Boolean
MsgBox "ЭкспортОтчетаПоКлиентам"
' call OpenMyForm(NameForm As String, Optional MyContr As String = "")
End Function
'''''---------------------------------------------------------------------------------------
''''' Procedure : ToPDF
''''' Author : IHAR
''''' Purpose : КОНВЕРТАЦИЯ В ПДФ
'''''---------------------------------------------------------------------------------------
''''Public Function ToPDF() As Boolean
''''Dim i As Long, intResult As Integer
''''Dim MyHwnd As Long, MyLngEr As Long
''''Dim MyFile As String, strPathPDF As String
''''
'''' On Error GoTo ToPDF_Error
''''
''''MyHwnd = 0
''''NameActFrm = MyScreenActFrm(1, , MyHwnd)
'''''Stop
''''Do While i < Reports.Count ' проверка всех форм и их id
'''' If Reports.Item(i).Name = NameActFrm Then
'''' If Reports.Item(i).Hwnd = MyHwnd Then
'''' NameActFrm = NameActFrm & "Print"
'''' 'проверка наличия строки имени
'''' If NameActFrm = "" Then MyLngEr = "a"
''''
'''' '----Если есть документ с таким же названием и местом расположения, выдается сообщение о замене
''''NewStart:
'''' MyFile = Replace(strDB_MyPatch & "\Cases\", "\\", "\") & Reports.Item(i)!IdCase & "_ARB"
'''' ' искать файлы с таким именем и расширением не dotx
'''' strPathPDF = MyFile & "\AR1.pdf"
''''
'''' If Dir(strPathPDF) <> "" Then
'''' Select Case MsgBox("A document with this name already exists. Do you want to replace it?", vbYesNo Or vbQuestion Or vbDefaultButton2, "Document Already Exists!")
'''' Case vbYes
'''' If FileUnlocked(strPathPDF) = True Then
'''' Kill strPathPDF
'''' GoTo NewStart
'''' Else
'''' MsgBox "Please close previously created PDF file, which you are attempting to re-create.", vbCritical, "Attention!"
'''' GoTo CloseFunct
'''' End If
'''' Case vbNo 'открыть файл ...
'''' intResult = ShellExecute(Application.hWndAccessApp, "open", strPathPDF, 0, 0, SW_SHOWNORMAL)
'''' If intResult = 31 Then MsgBox "Unregistered file type", vbExclamation
'''' GoTo CloseFunct
'''' End Select
'''' End If
''''
'''' ' работаем с копией отчета
'''' DoCmd.OpenReport NameActFrm, acViewPreview, , , acHidden, "SELECT * FROM ExportsTemp WHERE IdWin=" & Reports.Item(i)!IdWin
'''' 'в пдф
'''' If SaveCreatePath(MyFile) = True Then
'''' Call CopyTemplateFiles(MyFile)
'''' If Len(strPathPDF) > 0 Then DoCmd.OutputTo acOutputReport, NameActFrm, acFormatPDF, strPathPDF, True
'''' End If
'''' 'затем закрываем
'''' DoCmd.Close acReport, NameActFrm, acSaveNo
'''' Exit Function
'''' End If
'''' End If
''''i = i + 1
''''Loop
''''CloseFunct:
''''
'''' On Error GoTo 0
'''' Exit Function
''''
''''ToPDF_Error:
'''' If Err.Number = 0 And Err.Number = 2501 Then
'''' ElseIf LogError(Err.Number, Err.Description, Erl, "ToPDF", "Usys_Main_Function_Rib", "") = True Then
''''' DoCmd.OpenForm "ErrorLog", acNormal, , , acFormReadOnly, acDialog
'''' Call ErrorLogFunct
'''' Else
'''' 'MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ToPDF of Usys_Main_Function_Rib", , "Error!"
'''' End If
''''
''''End Function
круто, спасибо. |
