【Excel VBA】フォルダ内のエクセルを一括印刷･PDF化

標準モジュール：PrintExcel.bas
Option Explicit
Sub PrintExcel(ByVal OpenFile As Variant, ByVal PRAM_TYPE As Integer)
  Dim FSO      As New Scripting.FileSystemObject
  Dim myWB     As Workbook
  Dim SaveFile As String
  Dim rc       As Integer
  
  On Error GoTo Err_Exit
  
  If StrConv(LCase(OpenFile), vbNarrow) Like "*.xls*" Then
  Else
    If PRAM_TYPE = 1 Then
      MsgBox "Excelブックではありません。", vbCritical, "エラー"
    End If
  End If
  
  If PRAM_TYPE = 1 Then
    rc = MsgBox("全シートを印刷しますか？ 出力媒体＝" & RtnOutputMedia(), vbYesNo, "確認")
    If rc = vbYes Then
    Else
      Exit Sub
    End If
  End If
  
  With FSO
    If .FileExists(OpenFile) = True Then
      SaveFile = .GetParentFolderName(OpenFile) & "" & _
                 .GetBaseName(OpenFile) & ".pdf"
    Else
      Exit Sub
    End If
  End With
  
  On Error Resume Next
  Open OpenFile For Append As #1
  Close #1
  On Err GoTo Err_Exit
  
  If Err.Number <> 0 Then GoTo Err_Exit
  
  Set myWB = Workbooks.Open(FileName:=OpenFile, ReadOnly:=True, UpdateLinks:=0, _
               IgnoreReadOnlyRecommended:=True, Notify:=False, Password:="", Local:=True)
               
  If Err.Number <> 0 Then GoTo Err_Exit
  
  If PRAM_TYPE = 0 Then
    If RtnOutputMedia() = "紙" Then
      myWB.PrintOut Copies:=1, Collate:=True
    Else
      myWB.ExportAsFixedFormat Type:=xlTypePDF, FileName:=SaveFile
    End If
  Else
    If RtnOutputPreview() = True Then
      myWB.PrintOut Copies:=1, Collate:=True, Preview:=True
    End If
    
    rc = MsgBox("出力しますか？ 出力媒体＝" & RtnOutputMedia(), vbYesNo, "確認")
    If rc = vbYes Then
      If RtnOutputMedia() = "紙" Then
        myWB.PrintOut Copies:=1, Collate:=True
      Else
        myWB.ExportAsFixedFormat Type:=xlTypePDF, FileName:=SaveFile
      End If
    End If
  End If
  
Err_Exit:
  Set FSO = Nothing
  
  myWB.Close False
  Set myWB = Nothing
  
  If PRAM_TYPE = 0 Then Exit Sub
  
  If Err.Number <> 0 Then
    If Err.Number = 18 Then
      MsgBox "キャンセルしました。", vbCritical, "エラー"
    Else
      MsgBox "予期せぬエラー" & Err.Number, vbCritical, "エラー"
    End If
  Else
    MsgBox "処理完了しました。"
  End If
End Sub

Sub PrintExcelAll()
  Dim i  As Long
  Dim rc As Integer
  
  rc = MsgBox("一覧上のブックを一括で全シート印刷しますか？" & vbLf & _
              "※プレビューは無効になります。" & vbLf & _
              "出力媒体＝" & RtnOutputMedia(), vbYesNo, "確認")
  If rc = vbYes Then
  Else
    Exit Sub
  End If
  
  On Error GoTo Err_Exit
  
  Application.StatusBar = "処理中です..."
  Application.ScreenUpdating = False
  Application.Cursor = xlWait
  Application.EnableCancelKey = xlErrorHandler
  
  With ThisWorkbook.ActiveSheet
    For i = 10 To .Cells(Rows.Count, 2).End(xlUp).Row
      Call PrintExcel(.Cells(i, 2) & "" & .Cells(i, 3), 0)
      If Err.Number <> 0 Then
        If Err.Number = 18 Then GoTo Err_Exit
        .Cells(i, 7).Value = "Err"
      Else
        .Cells(i, 7).Value = ""
      End If
    Next
    .Activate
    MsgBox "処理完了しました。"
  End With
  
Err_Exit:
  Application.StatusBar = False
  Application.ScreenUpdating = True
  Application.Cursor = xlDefault
  Application.EnableCancelKey = xlInterrupt
End Sub

Function RtnOutputMedia() As String
  With ThisWorkbook.ActiveSheet
    Select Case True
      Case .OptionButtons("Option_Paper").Value = xlOn
        RtnOutputMedia = "紙"
      Case .OptionButtons("Option_PDF").Value = xlOn
        RtnOutputMedia = "PDF"
      Case Else
        RtnOutputMedia = "PDF"
    End Select
  End With
End Function

Function RtnOutputPreview() As Boolean
  With ThisWorkbook.ActiveSheet
    Select Case True
      Case .OptionButtons("Option_PreviewOn").Value = xlOn
        RtnOutputPreview = True
      Case .OptionButtons("Option_PreviewOff").Value = xlOn
        RtnOutputPreview = False
      Case Else
        RtnOutputPreview = True
    End Select
  End With
End Function