Excel VBAを活用したWord差し込み印刷結果を個別PDFで保存する手順

Sub WordBasicsDemo()
    Dim wdApp As Object, wdDoc As Object
    Dim failure As String
    On Error GoTo Failed
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = True
    Set wdDoc = wdApp.Documents.Add
    wdDoc.Content.InsertAfter "これはテスト文書です。"
    With wdDoc.Paragraphs(1).Range
        .Font.Name = "Arial"
        .Font.Size = 12
        .Bold = True
    End With
    MsgBox "テスト文書を確認してください。OKで保存せず閉じます。"
    GoTo CleanUp
Failed:
    failure = Err.Description
    Resume CleanUp
CleanUp:
    On Error Resume Next
    If Not wdDoc Is Nothing Then wdDoc.Close 0
    Set wdDoc = Nothing
    If Not wdApp Is Nothing Then
        If wdApp.Documents.Count = 0 Then wdApp.Quit 0
    End If
    Set wdApp = Nothing
    On Error GoTo 0
    If Len(failure) > 0 Then MsgBox failure, vbExclamation
End Sub

' テキストの挿入
wdDoc.Content.InsertAfter "これはテスト文書です。"

' テキストのスタイル設定
With wdDoc.Paragraphs(1).Range
    .Font.Name = "Arial"
    .Font.Size = 12
    .Bold = True
End With

' 完成例の処理を理解するための抜粋。単独実行不可。
ds.ActiveRecord = i
ds.FirstRecord = 1
ds.LastRecord = i
ds.FirstRecord = i
mainDoc.MailMerge.Destination = 0 ' wdSendToNewDocument
mainDoc.MailMerge.Execute True
Set mergedDoc = wdApp.ActiveDocument
mergedDoc.ExportAsFixedFormat pdfPath, 17, False ' wdExportFormatPDF
mergedDoc.Close 0 ' wdDoNotSaveChanges

Option Explicit

Public Sub SaveAsIndividualPDFs()
    Const wdSendToNewDocument As Long = 0
    Const wdFormLetters As Long = 0
    Const wdMainAndDataSource As Long = 2
    Const wdMainAndSourceAndHeader As Long = 4
    Const wdExportFormatPDF As Long = 17
    Const wdDoNotSaveChanges As Long = 0

    Dim wdApp As Object, mainDoc As Object, mergedDoc As Object
    Dim ds As Object, fso As Object
    Dim selectedRecords As Collection
    Dim mainPath As String, outputRoot As String
    Dim runFolder As String, pdfPath As String
    Dim recordCount As Long, i As Long, savedCount As Long
    Dim recordNumber As Variant
    Dim failure As String, cleanupNote As String
    Dim completed As Boolean

    On Error GoTo Failed
    mainPath = "C:\MergeDemo\Letter.docx"
    outputRoot = "C:\MergeDemo\PDF"
    Set fso = CreateObject("Scripting.FileSystemObject")

    If Not fso.FileExists(mainPath) Then
        Err.Raise vbObjectError + 1001, , "差し込み元文書がありません。"
    End If
    If Not fso.FolderExists(outputRoot) Then
        Err.Raise vbObjectError + 1002, , "保存先の親フォルダーがありません。"
    End If

    ' 既に開いているWordには接続しない。
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = True
    ' 引数順: FileName, ConfirmConversions, ReadOnly, AddToRecentFiles
    Set mainDoc = wdApp.Documents.Open(mainPath, False, True, False)

    With mainDoc.MailMerge
        If .MainDocumentType <> wdFormLetters Then
            Err.Raise vbObjectError + 1003, , "手紙形式の差し込み元文書が必要です。"
        End If
        If .State <> wdMainAndDataSource And _
           .State <> wdMainAndSourceAndHeader Then
            Err.Raise vbObjectError + 1004, , "保存済みのデータソース接続を確認してください。"
        End If
        Set ds = .DataSource
    End With
    ' NEXT/NEXTIF/SKIPIFがあるテンプレートは使用しない。
    CheckRecordControlFields mainDoc

    recordCount = ds.RecordCount
    If recordCount < 1 Then
        Err.Raise vbObjectError + 1005, , _
            "件数が0または不明です。Wordの宛先一覧と接続を確認してください。"
    End If

    ' Wordの現在の検索・並べ替え結果に対する番号を保存する。
    Set selectedRecords = New Collection
    For i = 1 To recordCount
        ds.ActiveRecord = i
        If ds.ActiveRecord <> i Then
            Err.Raise vbObjectError + 1006, , "指定レコードを選択できません。"
        End If
        If ds.Included Then selectedRecords.Add i
    Next i
    If selectedRecords.Count = 0 Then
        Err.Raise vbObjectError + 1007, , "選択されている宛先がありません。"
    End If

    If MsgBox("接続先: " & ds.Name & vbCrLf & _
              "選択された " & selectedRecords.Count & " 件をPDFにします。" & vbCrLf & _
              "宛先・絞り込み条件・テスト結果を確認済みですか？", _
              vbOKCancel + vbQuestion, "実行前の確認") <> vbOK Then
        GoTo CleanUp
    End If

    ' 毎回新しいフォルダーに出す。前回のPDFは再利用しない。
    runFolder = CreateNewRunFolder(fso, outputRoot)
    mainDoc.MailMerge.Destination = wdSendToNewDocument
    ds.FirstRecord = 1
    ds.LastRecord = recordCount

    For Each recordNumber In selectedRecords
        i = CLng(recordNumber)
        If ds.RecordCount <> recordCount Then
            Err.Raise vbObjectError + 1008, , "処理中にデータ件数が変わりました。"
        End If
        ds.ActiveRecord = i
        If ds.ActiveRecord <> i Or Not ds.Included Then
            Err.Raise vbObjectError + 1009, , "宛先の選択状態が変わりました。"
        End If
        ' ActiveRecordだけでは差し込み範囲は限定されない。
        ds.LastRecord = i
        ds.FirstRecord = i

        pdfPath = fso.BuildPath(runFolder, _
                    "Record_" & Format$(i, "000000") & ".pdf")
        If fso.FileExists(pdfPath) Or fso.FolderExists(pdfPath) Then
            Err.Raise vbObjectError + 1010, , "同名の保存先があるため停止します。"
        End If
        If wdApp.Documents.Count <> 1 Then
            Err.Raise vbObjectError + 1011, , "専用Wordに別の文書が開いています。"
        End If

        mainDoc.Activate
        ' True: 差し込みエラー時にWordの確認画面で停止する。
        mainDoc.MailMerge.Execute True
        If wdApp.Documents.Count <> 2 Then
            Err.Raise vbObjectError + 1012, , "差し込み結果を1文書として取得できません。"
        End If
        Set mergedDoc = wdApp.ActiveDocument
        If mergedDoc Is mainDoc Then
            Set mergedDoc = Nothing
            Err.Raise vbObjectError + 1013, , "差し込み元文書はPDFにしません。"
        End If

        ' 引数順: OutputFileName, ExportFormat, OpenAfterExport
        mergedDoc.ExportAsFixedFormat pdfPath, wdExportFormatPDF, False
        If Not fso.FileExists(pdfPath) Then
            Err.Raise vbObjectError + 1014, , "PDFの作成を確認できません。"
        End If
        If fso.GetFile(pdfPath).Size = 0 Then
            Err.Raise vbObjectError + 1015, , "空のPDFが作成されました。"
        End If
        savedCount = savedCount + 1
        mergedDoc.Close wdDoNotSaveChanges
        Set mergedDoc = Nothing
    Next recordNumber
    completed = True
    GoTo CleanUp

Failed:
    failure = "エラー " & Err.Number & ": " & Err.Description
    Resume CleanUp

CleanUp:
    ' 通常処理のエラーを隠さず、後始末のときだけ続行する。
    On Error Resume Next
    Set ds = Nothing
    If Not mergedDoc Is Nothing Then
        Err.Clear
        mergedDoc.Close wdDoNotSaveChanges
        If Err.Number <> 0 Then cleanupNote = "結果文書を閉じられませんでした。"
    End If
    Set mergedDoc = Nothing
    If Not mainDoc Is Nothing Then
        Err.Clear
        mainDoc.Close wdDoNotSaveChanges
        If Err.Number <> 0 Then cleanupNote = cleanupNote & " 元文書を閉じられませんでした。"
    End If
    Set mainDoc = Nothing
    If Not wdApp Is Nothing Then
        Err.Clear
        ' 所有を確認できない文書が残っていたら、勝手に閉じない。
        If wdApp.Documents.Count = 0 Then
            wdApp.Quit wdDoNotSaveChanges
        Else
            wdApp.Visible = True
            cleanupNote = cleanupNote & " Wordに残った文書を確認して手動で閉じてください。"
        End If
        If Err.Number <> 0 Then cleanupNote = cleanupNote & " Wordの終了状態を確認してください。"
    End If
    Set wdApp = Nothing
    Set fso = Nothing
    Set selectedRecords = Nothing
    On Error GoTo 0

    If Len(failure) > 0 Then
        MsgBox failure & vbCrLf & "保存確認済み: " & savedCount & " 件" & _
               vbCrLf & "出力先: " & runFolder & vbCrLf & _
               "途中のPDFは残しています。配布前に確認してください。" & _
               vbCrLf & cleanupNote, vbExclamation
    ElseIf completed Then
        MsgBox savedCount & " 件を保存しました。" & vbCrLf & runFolder & _
               vbCrLf & "内容と宛先を確認してから配布してください。" & _
               vbCrLf & cleanupNote, vbInformation
    Else
        MsgBox "キャンセルしました。" & vbCrLf & cleanupNote, vbInformation
    End If
End Sub

Private Function CreateNewRunFolder(ByVal fso As Object, _
                                     ByVal root As String) As String
    Dim baseName As String, candidate As String, suffix As Long
    baseName = "Run_" & Format$(Now, "yyyymmdd_hhnnss")
    For suffix = 0 To 9999
        candidate = fso.BuildPath(root, baseName & "_" & Format$(suffix, "0000"))
        If Not fso.FolderExists(candidate) And Not fso.FileExists(candidate) Then
            ' 競合して作成に失敗した場合も、上書きせずエラーで停止する。
            fso.CreateFolder candidate
            CreateNewRunFolder = candidate
            Exit Function
        End If
    Next suffix
    Err.Raise vbObjectError + 1016, , "新しい出力フォルダーを確保できません。"
End Function

Private Sub CheckRecordControlFields(ByVal doc As Object)
    Dim firstRange As Object, currentRange As Object, fld As Object
    For Each firstRange In doc.StoryRanges
        Set currentRange = firstRange
        Do While Not currentRange Is Nothing
            For Each fld In currentRange.Fields
                Select Case fld.Type
                    Case 41, 42, 43 ' wdFieldNext, wdFieldNextIf, wdFieldSkipIf
                        Err.Raise vbObjectError + 1017, , _
                            "NEXT/NEXTIF/SKIPIFのない手紙テンプレートを使ってください。"
                End Select
            Next fld
            Set currentRange = currentRange.NextStoryRange
        Loop
    Next firstRange
End Sub

Sub SampleSub()
    On Error GoTo ErrorHandler
    ' ここに通常の処理を記述

    Exit Sub
ErrorHandler:
    MsgBox "エラーが発生しました: " & Err.Description, vbCritical
    ' 必要に応じて追加のエラー処理をここに記述
End Sub

Sub OptimizeSub()
    Dim oldScreen As Boolean, oldEvents As Boolean
    Dim failure As String
    oldScreen = Application.ScreenUpdating
    oldEvents = Application.EnableEvents
    On Error GoTo Failed
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    ' ここに必要なExcel側の処理を記述
    GoTo CleanUp
Failed:
    failure = Err.Description
    Resume CleanUp
CleanUp:
    On Error Resume Next
    Application.EnableEvents = oldEvents
    Application.ScreenUpdating = oldScreen
    On Error GoTo 0
    If Len(failure) > 0 Then MsgBox failure, vbExclamation
End Sub