Добро пожаловать в форум, Guest  >>   Войти | Регистрация | Поиск | Правила | В избранное | Подписаться
Все форумы / Microsoft Access Новый топик    Ответить
Топик располагается на нескольких страницах: Ctrl  назад   1 2 [3]      все
 Re: Делимся нашими наработками?  [new]
alecko
Member

Откуда: Башкирия
Сообщений: 541
Игортан, да и мне можно не только сохранить в таблице а сразу и применить. руки как -то не доходят-но помню была тема давно.
31 окт 18, 21:47    [21720893]     Ответить | Цитировать Сообщить модератору
 Re: Делимся нашими наработками?  [new]
Игортан
Member

Откуда: Беларусь
Сообщений: 873
Озверин

Сюда просто положить, много кусков архива будет.

alecko отправил на маил, у вас маил закрыт.
1 ноя 18, 01:24    [21720980]     Ответить | Цитировать Сообщить модератору
 Re: Делимся нашими наработками?  [new]
Joss
Member

Откуда: г. Минск
Сообщений: 4884
Можно выложить на файлообменник. Все, кому надо - заберут.
1 ноя 18, 08:53    [21721057]     Ответить | Цитировать Сообщить модератору
 Re: Делимся нашими наработками?  [new]
Озверин
Member

Откуда: Ростов-на-Дону
Сообщений: 5183
Joss
Можно выложить на файлообменник. Все, кому надо - заберут.


я как-то предлагал сделать гитхаб наш ;) Через билдер можно туда исходники выгружать ...
1 ноя 18, 09:16    [21721073]     Ответить | Цитировать Сообщить модератору
 Re: Делимся нашими наработками?  [new]
alecko
Member

Откуда: Башкирия
Сообщений: 541
Игортан, спасибо, получил.
WOW.
Конструктор шикарный, много нового узнал-Вы разобрались в этом на порядок глубже.
1 ноя 18, 10:19    [21721147]     Ответить | Цитировать Сообщить модератору
 Re: Делимся нашими наработками?  [new]
Озверин
Member

Откуда: Ростов-на-Дону
Сообщений: 5183
alecko, могли бы вы на какой-нить дропбокс выложить или на гуглдрайв и расшарить?
1 ноя 18, 10:21    [21721150]     Ответить | Цитировать Сообщить модератору
 Re: Делимся нашими наработками?  [new]
Joss
Member

Откуда: г. Минск
Сообщений: 4884
Так же хотелось бы посмотреть.

Дополнительно
Ribbon XML Editor - бесплатный.
1 ноя 18, 10:28    [21721162]     Ответить | Цитировать Сообщить модератору
 Re: Делимся нашими наработками?  [new]
Озверин
Member

Откуда: Ростов-на-Дону
Сообщений: 5183
Joss
Так же хотелось бы посмотреть.

Дополнительно
Ribbon XML Editor - бесплатный.


До кучи, из этой же темы: https://www.ribboncreator2016.de/en/
1 ноя 18, 10:34    [21721178]     Ответить | Цитировать Сообщить модератору
 Re: Делимся нашими наработками?  [new]
Joss
Member

Откуда: г. Минск
Сообщений: 4884
Озверин
Joss
Так же хотелось бы посмотреть.

Дополнительно
Ribbon XML Editor - бесплатный.


До кучи, из этой же темы: https://www.ribboncreator2016.de/en/
На предыдущей странице MrShin про него и писал
1 ноя 18, 11:13    [21721229]     Ответить | Цитировать Сообщить модератору
 Re: Делимся нашими наработками?  [new]
Игортан
Member

Откуда: Беларусь
Сообщений: 873
Озверин,

Да там ничего такого особенного нет.
От внешних картинок отказался, есть возможность собрать ленту из минимально необходимых компонентов.
Нету настройки меню по кнопке меню(2007) или вкладки (2010 и выше)

логин – a (латинская)
Пароль – 111

Большой вес. Резал, резал...
оставил только конструктор и настройку
потом посмотрите – лента сохраняется в USys_Ribbons_Ready
настройки надписи, видимости и доступности в таблице Usys_Ribbon_TypeUser

Все действительно почти на ручном режиме. Когда то была задумка сделать многое, потом все как то поостыло.
Потому, как есть…
Просто пользуюсь как относительно быстрым конструктором.

расшарил папку.
https://yadi.sk/d/xasiU_z0e8Dhsw
1 ноя 18, 11:17    [21721233]     Ответить | Цитировать Сообщить модератору
 Re: Делимся нашими наработками?  [new]
Игортан
Member

Откуда: Беларусь
Сообщений: 873
Игортан,

До кучи, реально используемый модуль для ленты
+

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



и модуль для вызова функций. Сюда направляются все вызовы. С ленты, кнопок, контекстного меню.
Для универсальности.
Из развивающегося проекта
+

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

1 ноя 18, 11:24    [21721240]     Ответить | Цитировать Сообщить модератору
 Re: Делимся нашими наработками?  [new]
Игортан
Member

Откуда: Беларусь
Сообщений: 873
Joss
Дополнительно
Ribbon XML Editor - бесплатный.

В нем, кстати, и проверяю структуру после создания
1 ноя 18, 11:42    [21721256]     Ответить | Цитировать Сообщить модератору
 Re: Делимся нашими наработками?  [new]
Joss
Member

Откуда: г. Минск
Сообщений: 4884
Дополнительно Настройка пользовательского интерфейса приложений Microsoft Office уроки по Ribbon XML Editor
1 ноя 18, 11:59    [21721287]     Ответить | Цитировать Сообщить модератору
 Re: Делимся нашими наработками?  [new]
Озверин
Member

Откуда: Ростов-на-Дону
Сообщений: 5183
Игортан
Игортан,

До кучи, реально используемый модуль для ленты
+

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



и модуль для вызова функций. Сюда направляются все вызовы. С ленты, кнопок, контекстного меню.
Для универсальности.
Из развивающегося проекта
+

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



круто, спасибо.
1 ноя 18, 12:01    [21721293]     Ответить | Цитировать Сообщить модератору
 Re: Делимся нашими наработками?  [new]
Игортан
Member

Откуда: Беларусь
Сообщений: 873
Joss
Ribbon XML Editor - бесплатный.

там есть только одна маленькая проблема, не помню точно, но у себя вроде это решил ибо не попадаю на нее.
Нет проверки на взаимоисключающие команды.
Типа getLabel и Label.

При нахождении их обоих для одного контрола не бьет ошибку.

А так, хорошая вещь. Видно все нутро, но для конструирования, нужны знания.
Если нужно, скину ссыль на книгу по риббон 2007, правда eng.
1 ноя 18, 12:30    [21721349]     Ответить | Цитировать Сообщить модератору
 Re: Делимся нашими наработками?  [new]
Озверин
Member

Откуда: Ростов-на-Дону
Сообщений: 5183
Тут если у кого пример с деревьями не открывался только из-за контрола дерева, у меня заработало на работе так:


У кого не работает пример с деревом:

1. Копируем библиотеку отсюда: https://drive.google.com/file/d/1Qhe20fXbjKW6G-A5rMnnDq8y0a5ODq6c/view?usp=sharing
2. Копируем себе куда-нибудь в папку(лучше, наверное, не заменять существующую библиотеку)
3. Регистрируем ее regsvr32.exe путь_к_файлу (лучше под админом, конечно)
4. Заходим в проект, старую либо отвязыем(Microsoft Common Control)
5. Новую привязываем
1 ноя 18, 13:31    [21721469]     Ответить | Цитировать Сообщить модератору
 Re: Делимся нашими наработками?  [new]
Игортан
Member

Откуда: Беларусь
Сообщений: 873
Игортан,

Господа, перестарался резать...
новый ссыль на полную версию, раз пошла такая пьянка
https://yadi.sk/d/RyQbKKjF2D7wwQ
1 ноя 18, 13:36    [21721481]     Ответить | Цитировать Сообщить модератору
 Re: Делимся нашими наработками?  [new]
Лапух
Member

Откуда: Стойбище № 7
Сообщений: 865
alecko
...оставим тот топик Лапуху...

Меня, - Спящего будить?
Вы точно этого возжаждали, яко бы бессмертные и бесстрашные типа бОГИ?
1 ноя 18, 18:50    [21721863]     Ответить | Цитировать Сообщить модератору
 Re: Делимся нашими наработками?  [new]
nikolay_magagin
Member

Откуда: Псков
Сообщений: 170
Завершающей ситуацией любой программы для пользователя является отчет. Отчет пользователя включает в себя обычно очень много итоговой информации по определенному шаблону. Иногда возникает необходимость увидеть часть информации. Для этой цели создается новый отчет или создается дерево для перехода на формы с данной информацией с применением дополнительных фильтров.
Я попытался совместить все это в отчетах.
1) Дерево – осуществляются переходы по отчетам в сторону более подробной информации. Например отчет отражает данные по отделам организации. Переход в следующий отчет отражает выбранный отдел с ФИО сотрудников.
2) Фильтры – при переходе автоматически задается основной фильтр.
3) Визуализация – все видно крупно на весь экран и не надо всматриваться в мелкий список дерева. Отражается лишь та информация с которой работаешь.
4) Неперегруженость информации в формах – в форме отражается информация только по таблице. Например из отчета по отделам организации выходишь на форму по созданию новой записи отдела. Из формы по сотрудникам на новую запись по сотрудникам и по желанию на изменение записи по выбранному отделу.
Единственно очень сложно понять наиболее лучший вид перехода.
5 ноя 18, 00:34    [21723887]     Ответить | Цитировать Сообщить модератору
 Re: Делимся нашими наработками?  [new]
Озверин
Member

Откуда: Ростов-на-Дону
Сообщений: 5183
nikolay_magagin, так а сама попытка где?
6 ноя 18, 14:28    [21725274]     Ответить | Цитировать Сообщить модератору
 Re: Делимся нашими наработками?  [new]
nikolay_magagin
Member

Откуда: Псков
Сообщений: 170
Грубо , примерно так.

К сообщению приложен файл (Пример.rar - 71Kb) cкачать
9 ноя 18, 17:53    [21729972]     Ответить | Цитировать Сообщить модератору
 Re: Делимся нашими наработками?  [new]
alecko
Member

Откуда: Башкирия
Сообщений: 541
alecko
динамически изменяемые формы - да, думаю что стоит рассказать о своем подходе (но это ж надо оформить и код и описание), а вот надо ли оно кому-это вопрос.

запилил!, ну кому надо те наверное и так в курсе, однако галочку что выполнил поставить нужно...
27 ноя 18, 20:15    [21746561]     Ответить | Цитировать Сообщить модератору
Топик располагается на нескольких страницах: Ctrl  назад   1 2 [3]      все
Все форумы / Microsoft Access Ответить