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