ACCESS にて、印刷ダイアログ１回で複数のレポートを印刷したい

検索すると、質問としてはかなりの数が発見できるが、満足のいく回答はみあたらない。というわけで、Access VBA 初心者っぽく作ってみました。

レポート RptA, RptB, RptC, ... と不特定にある
UI には「個々のレポートの印刷ボタン」と「すべて印刷ボタン」がある。
実稼働環境では、プリンタ P1, P2, P3, ... があり、P1 がデフォルトプリンタである
レポートは、任意のプリンタから出力できるようにプリンタが選択できる。
「すべて印刷ボタン」を押すと選択した１つのプリンタから複数のレポートすべてが出力される。

「同時に印刷したいレポートを、すべてサブレポートとして参照したレポートを作成する」という手法は、設計可能なレポートサイズが用紙サイズの２倍までという制限から、多くの場合は採用できない。というわけで、VBA のコーディングで頑張る方向になる。

まずは、印刷ボタン→印刷ダイアログ→印刷という処理。

Const PrintSuccess      = 0
Const PrintCancel       = 1
Const PrintErrorOpen    = 4
Const PrintErrorUnknown = 15

' TargetReport : 印刷対象のレポート
' PrintFilter  : 印刷対象のフィルタ
' ShowPreview  : プレビューを表示するかどうか
Public Function PrintOne(TargetReport As String, PrintFilter as String, Optional ShowPreview as Boolean = True) As Integer
    PrintOne = PrintErrorUnknown

    ' レポートを開く
    On Error Goto CatchOpenReportException
    DoCmd.OpenReport TargetReport, acViewPreview, , PrintFilter, IIf(ShowPreview, acWindowNormal, acHidden)

    ' プレビューありの場合、フォーマット＆レンダリングが完了するのを待つ
    If ShowPreview Then DoEvents

    ' 印刷ダイアログを呼び出す
    On Error Goto CatchCancelPrintingException
    DoCmd.SelectObject acReport, TargetReport, False
    DoCmd.RunCommand acCmdPrint

    PrintOne = PrintSuccess

ExitPrintOne:
    ' 終了処理
    DoCmd.Close acReport, TargetReport, acSaveYes
    Exit Sub

CatchOpenReportException:
    ' レポートの初期化中および関連イベントのどこかで例外が発生したり、
    ' イベントハンドラが Cancel = True とした場合に、この例外ハンドラに到達する。
    '     例えば NoData イベントで Cancel = True としておくと、フィルタ結果が０件に
    '     なった場合に、このエラーハンドラに飛びます。
    PrintOne = PrintErrorOpen
    Goto ExitPrintOne

CatchCancelPrintingException:
    ' 印刷ダイアログでキャンセルボタンを押した
    PrintOne = PrintCancel
    Goto ExitPrintOne
End Sub

続いて、すべて印刷ボタン→印刷ダイアログ→印刷→印刷→印刷...

' TargetReports : 印刷対象のレポートの配列
' PrintFilter   : 印刷対象のフィルタ
Public Function PrintAll(TargetReports() As String, PrintFilter as String) As Integer
    PrintAll = PrintErrorUnknown

    Dim ub as Integer
    Dim i as Integer
    ub = LBound(TargetReports)

    ' レポートを非表示で開く
    On Error Goto CatchOpenReportException
    DoCmd.OpenReport TargetReports(ub), acViewPreview, , PrintFilter, acHidden

    ' 印刷ダイアログを呼び出す
    On Error Goto CatchCancelPrintingException
    DoCmd.SelectObject acReport, TargetReports(ub), False
    DoCmd.RunCommand acCmdPrint

    On Error Goto 0
    Dim rpt As Report
    Dim prt As String
    Dim dm As String

    ' 印刷に使用したプリンタを取得する
    Set rpt = Reports(TargetReports(ub))   ' 直接 Reports().Printer では取得できない
    prt = rpt.Printer.DeviceName           ' なぜだろうか？
    dm  = rpt.Printer.PrtDevMode

    ' 残りのレポートを印刷する
    For i = LBound(TargetReports) To UBound(TargetReports)
      If Not i = ub Then
        ' レポートを非表示で開く
        On Error Goto CatchOpenReportException
        DoCmd.OpenReport TargetReports(i), acViewPreview, , PrintFilter, acHidden
        
        ' プリンタを設定する
        Set rpt = Reports(TargetReports(i))
        rpt.Printer = Application.Printers(prt)
        rpt.PrtDevMode = dm

        ' 印刷ダイアログなしで印刷
        On Error Goto ExitPrintAll
        DoCmd.OpenReport TargetReports(i), acViewNormal, , PrintFilter
      End If

      ' レポートを閉じる
      DoCmd.Close acReport, TargetReports(i), acSaveYes
    Next i

    PrintAll = PrintSuccess

ExitPrintAll:
    ' 終了処理
    On Error Resume Next
    For i = LBound(TargetReports) To UBound(TargetReports)
      DoCmd.Close acReport, TargetReports(i), acSaveYes
    Next i
    Exit Sub

CatchOpenReportException:
    ' レポートの初期化中および関連イベントのどこかで例外が発生したり、
    ' イベントハンドラが Cancel = True とした場合に、この例外ハンドラに到達する。
    '     例えば NoData イベントで Cancel = True としておくと、フィルタ結果が０件に
    '     なった場合に、このエラーハンドラに飛びます。
    PrintAll = i * 16 + PrintErrorOpen
    Goto ExitPrintAll

CatchCancelPrintingException:
    ' 印刷ダイアログでキャンセルボタンを押した
    PrintAll = PrintCancel
    Goto ExitPrintAll
End Sub

実際は、複数レコードを RptA(1) → RptB(1) → RptC(1) → RptA(2) → RptB(2) → RptC(2) といった部単位印刷のサポートも含めたものになっているので、これは適当に hatena 上に直接書いたものである。