'--------------------------------------------------------------------
' Module    : modReportsPrinterReset
' Author    : es
' Date      : 17.01.2004
'--------------------------------------------------------------------
'Модуль ПЕРЕУСТАНОВКИ "принтерных" настроек всех отчетов
'под текущий принтер по умолчанию т.е. с настроек принтера разработчика
'на настройки принтера пользователя
'--------------------------------------------------------------------
Option Compare Database
Option Explicit

Private Type str_DEVMODE
    RGB As String * 94
End Type
'--------------------------------------------------------------------
Private Type type_DEVMODE
    strDeviceName As String * 16
    intSpecVersion As Integer
    intDriverVersion As Integer
    intSize As Integer
    intDriverExtra As Integer
    lngFields As Long
    intOrientation As Integer
End Type

Public Sub esResetAllReportsToDefPrinter()
'Смена у всех отчетов настроек принтера с "зашитых внутри отчета"
' на текущий принтер по умолчанию и его настройки
' затирает только данные по принтеру - поля и ориентация остаются прежними
'--------------------------------------------------------------------
Dim dbs As Database, ctr As Container, doc As Document
Dim objReport As Report
Dim OldOrientation As Integer 'Для запоминания старой ориентации _
   т.к. она (ориентация) входит в Свойство PrtDevMode отчета _
   кое собираемся переписывать по новой
    
On Error GoTo esResetAllReportsToDefPrinterErr
'Выключ. отображение процесса
    Application.Echo False
    Set dbs = CurrentDb
    Set ctr = dbs.Containers!Reports
    'цикл по всем отчетам
    For Each doc In ctr.Documents
        'открытие отчета в режиме редакции
        DoCmd.OpenReport doc.name, acViewDesign
        Set objReport = Reports(doc.name)
        
        'отображение инфы о тек. отчете в Status Bar
        SysCmd acSysCmdSetStatus, "Обрабатываю Отчет - " & doc.name
        
        'Запоминаем старую ориентацию для последующего восстановления (см. функцию ниже)...
        OldOrientation = esReportOrientationSetGet(objReport, True)
        'Зачистка данных о принтере в отчете
        objReport.PrtDevMode = Null
        objReport.PrtDevNames = Null
        'Закрытие отчета с сохранением "пустого принтера"
        DoCmd.Close acReport, doc.name, acSaveYes

        'Если до этого у отчета была ориентация LandsCape
        '   то восстанавливаем ее, причем отчет уже "берет"
        '   принтер по умолчанию, при повторном открытии
        If OldOrientation = 2 Then
            'открытие отчета в режиме редакции
            DoCmd.OpenReport doc.name, acViewDesign
            Set objReport = Reports(doc.name)
            
            'Debug.Print objReport.Name
            'Восстанавливаем LandsCape ориентацию (см. функцию ниже)
            '   если была Portrait то восстанавливать нет необходимости
            '   т.к. она уже установлена по умолчанию
            esReportOrientationSetGet objReport
            'Закрытие отчета с сохранением
            DoCmd.Close acReport, doc.name, acSaveYes
        End If
    Next doc
    SysCmd (acSysCmdClearStatus)
'Включаем отображение процесса на экране обратно
    Application.Echo True
    Exit Sub
esResetAllReportsToDefPrinterErr:
    Application.Echo True
    MsgBox "Процедура [esResetAllReportsToDefPrinter] привела к ошибке:" & vbCrLf & _
    Err.Description & vbCrLf & " Err#" & Err.Number & vbCrLf & _
    "При обработке Отчета - " & doc.name, vbCritical
End Sub

'--------------------------------------------------------------------
Private Function esReportOrientationSetGet(objCurReport As Report, _
                    Optional GetOnly As Boolean) As Integer
'Вспомогательная функция ,в зависимости от параметра GetOnly,
'ИЛИ :
'Возвращает код ориентации отчета
'   Portrait = 1
'   LandsCape= 2
'ИЛИ если GetOnly=False (по умолчанию):
'   делает ориентацию открытого отчета = LandsCape
'--------------------------------------------------------------------

Dim DevString As str_DEVMODE
Dim DM As type_DEVMODE
Dim strDevModeExtra As String

On Error GoTo esReportOrientationSetGetErr
    If Not IsNull(objCurReport.PrtDevMode) Then
        strDevModeExtra = objCurReport.PrtDevMode
        DevString.RGB = strDevModeExtra
        LSet DM = DevString
        esReportOrientationSetGet = DM.intOrientation
        'Если только задано параметром то вносим изменения в отчет
        If GetOnly = False Then
            'Меняем ориентацию  = LandsCape
            DM.intOrientation = 2
            LSet DevString = DM
            Mid(strDevModeExtra, 1, 94) = DevString.RGB
            objCurReport.PrtDevMode = strDevModeExtra
        End If
    End If
    Exit Function
esReportOrientationSetGetErr:
    If GetOnly = True Then
        strDevModeExtra = "При определении ориентации Отчета - " & _
        objCurReport.name
    Else
        strDevModeExtra = "При установке ориентации Отчета - " & _
        objCurReport.name
    End If
    MsgBox "Процедура [esReportOrientationSetGet] привела к ошибке:" & vbCrLf & _
    Err.Description & vbCrLf & " Err#" & Err.Number & vbCrLf & _
    strDevModeExtra, vbCritical
End Function

Sub PrintReport(rpt, copies)
Dim TotPages, x, i1, i2
'Приостанавливаем вывод на экран (не обязательно)
Application.Echo False

'Открываем первый отчет Счета Фактуры
DoCmd.OpenReport rpt, acPreview
DoCmd.Minimize
'скрываем окно отчета (не обязательно)
Reports(rpt).Visible = False
Reports(rpt).Me.Printer.Duplex = acPRDPVertical
'Включаем вывод на экран
Application.Echo True

'Проверка на наличие данных в открытом отчете (только в одном)
'т.к. подразумевается что набор зап. второго полностью аналогичен
If Reports(rpt).HasData = 0 Then
   MsgBox "Нечего печатать!!! " & vbCrLf & _
   "отчеты:" & vbCrLf & "[" & rpt & "]" & vbCrLf & _
   "не имеeт данных", vbCritical
   'переход на метку закрытия отчетов
   GoTo jsPipeLinePrintExit
End If

'Подсчет необходимых листов бумаги и установка концовки цикла
TotPages = Reports(rpt).Pages
x = TotPages
TotPages = TotPages * copies

'If MsgBox("Вставьте в принтер " & TotPages & " листов !", vbOKCancel) = vbOK Then
   'For i = 1 To x
   DoCmd.SelectObject acReport, rpt

   'печатаем со стр. i по стр. i с высоким разрешением заданное к-во копий
   DoCmd.PrintOut acAll, , , , copies, True
   'Next
'End If

jsPipeLinePrintExit:
On Error Resume Next
DoCmd.Close acReport, rpt

Exit Sub

jsPipeLinePrintErr:
Application.Echo True
MsgBox Err.Description & ""
'Debug.Print Err.Description & vbCrLf & "Ощибка №" & Err.Number
Err.Clear
Resume jsPipeLinePrintExit

End Sub