Wordの差し込み印刷を1件ずつ印刷してホチキス留めする方法｜2件目から外れるときの対処

Option Explicit

'==========================================
' 差し込み印刷 1件ずつ出力ツール
'
' 【管理者向け】プリンターを変更する場合は
'   下の PRINTER_NAME の "" の中を書き換えてください。
'   正確な名前は ListPrinters を実行すると確認できます。
'==========================================
Private Const PRINTER_NAME  As String = "ここにプリンター名"   'ListPrinters で確認して書き換える
Private Const WAIT_SECONDS  As Long = 3
Private Const DEFAULT_COPIES As Long = 1   '1件あたりの部数の初期値


'==========================================
' ★ボタンから呼ばれるのはこれ
'==========================================
Sub 差込印刷_ホチキス()
    Dim doc As Document
    Dim n As Long, firstRec As Long, lastRec As Long
    Dim i As Long, cnt As Long, c As Long, nCopies As Long
    Dim ans As String
    Dim savedDefault As String, switched As Boolean

    Set doc = ActiveDocument

    '--- 差込文書かどうか確認
    If doc.MailMerge.MainDocumentType = wdNotAMergeDocument Then
        MsgBox "この文書は差込文書ではありません。" & vbCrLf & _
               "差込設定を済ませた文書を開いてから実行してください。", _
               vbExclamation, "差込印刷"
        Exit Sub
    End If

    '--- 件数取得
    On Error Resume Next
    n = doc.MailMerge.DataSource.RecordCount
    On Error GoTo 0

    If n < 1 Then
        MsgBox "宛先データを読み取れませんでした。" & vbCrLf & _
               "［差し込み文書］タブで宛先ファイルが選ばれているか確認してください。", _
               vbExclamation, "差込印刷"
        Exit Sub
    End If

    '--- 印刷範囲の選択
    ans = InputBox( _
        "宛先は全部で " & n & " 件あります。" & vbCrLf & vbCrLf & _
        "どれを印刷しますか？ 下の欄に入力してください。" & vbCrLf & vbCrLf & _
        "  すべて印刷      →  全部" & vbCrLf & _
        "  3件目だけ        →  3" & vbCrLf & _
        "  5件目から12件目 →  5-12" & vbCrLf & _
        "  1と4と7件目     →  1,4,7" & vbCrLf & vbCrLf & _
        "※件数はExcelの見出し行を除いた上からの順番です。", _
        "印刷する宛先の指定", "全部")

    If StrPtr(ans) = 0 Then Exit Sub          'キャンセル
    ans = Trim$(Replace(Replace(ans, "　", ""), " ", ""))
    If ans = "" Then Exit Sub

    Dim recList() As Long
    If Not ParseRange(ans, n, recList, cnt) Then
        MsgBox "入力内容を読み取れませんでした。" & vbCrLf & vbCrLf & _
               "「全部」「3」「5-12」「1,4,7」のいずれかの形で" & vbCrLf & _
               "1〜" & n & " の範囲で入力してください。", _
               vbExclamation, "入力エラー"
        Exit Sub
    End If

    '--- 部数の指定（1件を何部ずつ綴じるか）
    ans = InputBox( _
        "1件あたり何部ずつ印刷しますか？" & vbCrLf & vbCrLf & _
        "複数部ほしいときは、その数を入力してください。" & vbCrLf & _
        "試し刷りのときは 1 にしてください。" & vbCrLf & vbCrLf & _
        "※1部ずつ別々にホチキス留めされます。", _
        "部数の指定", CStr(DEFAULT_COPIES))

    If StrPtr(ans) = 0 Then Exit Sub          'キャンセル
    ans = Trim$(Replace(Replace(ans, "　", ""), " ", ""))
    nCopies = 0
    If IsNumeric(ans) Then nCopies = CLng(Val(ans))
    If nCopies < 1 Or nCopies > 20 Then
        MsgBox "部数は 1〜20 の数字で入力してください。", vbExclamation, "入力エラー"
        Exit Sub
    End If

    '--- 最終確認
    If MsgBox(cnt & " 件 × " & nCopies & " 部 ＝ 合計 " & (cnt * nCopies) & " 束を印刷します。" & vbCrLf & vbCrLf & _
              "プリンター： " & PRINTER_NAME & vbCrLf & vbCrLf & _
              "1件目を" & nCopies & "部つづけて出し、次に2件目を" & nCopies & "部…という順で出力します。" & vbCrLf & _
              "1部ごとに分けてホチキス留めされます。" & vbCrLf & vbCrLf & _
              "用紙とホチキス針の残量を確認してください。", _
              vbOKCancel + vbQuestion, "印刷の確認") <> vbOK Then Exit Sub

    '--- プリンター切替
    savedDefault = GetDefaultPrinter()
    If LCase$(savedDefault) <> LCase$(PRINTER_NAME) Then
        If SetDefaultPrinter(PRINTER_NAME) Then
            switched = True
        Else
            If MsgBox("プリンター「" & PRINTER_NAME & "」が見つかりませんでした。" & vbCrLf & vbCrLf & _
                      "現在の既定プリンター（" & savedDefault & "）で印刷しますか？" & vbCrLf & _
                      "※ホチキス留めされない可能性があります。", _
                      vbOKCancel + vbExclamation, "確認") <> vbOK Then Exit Sub
        End If
    End If

    '--- 印刷
    On Error GoTo Cleanup
    With doc.MailMerge
        .Destination = wdSendToPrinter
        For i = 1 To cnt
            .DataSource.FirstRecord = recList(i)
            .DataSource.LastRecord = recList(i)
            '1件を続けて必要部数ぶん出す。1部＝1ジョブなので1部ごとに綴じられる
            For c = 1 To nCopies
                .Execute Pause:=False
                Application.StatusBar = "印刷中... " & i & " / " & cnt & " 件（" & c & " / " & nCopies & " 部）"
                WaitSeconds WAIT_SECONDS
            Next c
        Next i
    End With

    Application.StatusBar = ""
    If switched Then SetDefaultPrinter savedDefault
    MsgBox cnt & " 件 × " & nCopies & " 部（合計 " & (cnt * nCopies) & " 束）をプリンターに送信しました。" & vbCrLf & _
           "出力が終わるまで少し時間がかかる場合があります。", _
           vbInformation, "完了"
    Exit Sub

Cleanup:
    Application.StatusBar = ""
    If switched Then SetDefaultPrinter savedDefault
    MsgBox "印刷中にエラーが発生しました。" & vbCrLf & vbCrLf & _
           "内容： " & Err.Description & vbCrLf & vbCrLf & _
           "途中まで印刷されている可能性があります。" & vbCrLf & _
           "プリンターの出力を確認してください。", vbCritical, "エラー"
End Sub


'==========================================
' 指定した秒数だけ待つ
'
' Word には Excel のような Application.Wait が無いため自前で用意する。
' DoEvents を挟んでいるので、待っている間に Word が
' 印刷ジョブをプリンターへ送り出せる（ここが重要）。
'==========================================
Private Sub WaitSeconds(ByVal secs As Long)
    Dim endT As Single
    endT = Timer + secs
    Do
        DoEvents
        If Timer >= endT Then Exit Do
        If Timer < secs Then Exit Do        '日付をまたいだときの保険
    Loop
End Sub


'==========================================
' 管理者用：プリンター名の確認
'==========================================
Sub ListPrinters()
    Dim wmi As Object, col As Object, p As Object, s As String
    Set wmi = GetObject("winmgmts:\\.\root\cimv2")
    Set col = wmi.ExecQuery("SELECT Name, Default FROM Win32_Printer")
    For Each p In col
        s = s & IIf(p.Default, "[既定] ", "        ") & p.Name & vbCrLf
    Next
    MsgBox "インストール済みプリンター：" & vbCrLf & vbCrLf & s & vbCrLf & _
           "現在の設定： " & PRINTER_NAME, vbInformation, "プリンター一覧"
End Sub


'==========================================
' 内部処理
'==========================================
Private Function ParseRange(ByVal s As String, ByVal maxRec As Long, _
                            ByRef outList() As Long, ByRef outCnt As Long) As Boolean
    Dim parts() As String, i As Long, j As Long
    Dim a As Long, b As Long, pos As Long
    Dim tmp() As Long

    ReDim tmp(1 To 10000)
    outCnt = 0

    If s = "全部" Or s = "すべて" Or s = "全て" Or LCase$(s) = "all" Then
        For i = 1 To maxRec
            outCnt = outCnt + 1
            tmp(outCnt) = i
        Next
        GoTo Done
    End If

    parts = Split(Replace(s, "，", ","), ",")
    For i = 0 To UBound(parts)
        If parts(i) = "" Then GoTo NextPart
        pos = InStr(Replace(parts(i), "−", "-"), "-")
        If pos > 0 Then
            a = SafeNum(Left$(parts(i), pos - 1))
            b = SafeNum(Mid$(parts(i), pos + 1))
            If a < 1 Or b < 1 Or a > maxRec Or b > maxRec Or a > b Then Exit Function
            For j = a To b
                outCnt = outCnt + 1
                tmp(outCnt) = j
            Next
        Else
            a = SafeNum(parts(i))
            If a < 1 Or a > maxRec Then Exit Function
            outCnt = outCnt + 1
            tmp(outCnt) = a
        End If
NextPart:
    Next

Done:
    If outCnt = 0 Then Exit Function
    ReDim outList(1 To outCnt)
    For i = 1 To outCnt
        outList(i) = tmp(i)
    Next
    ParseRange = True
End Function

Private Function SafeNum(ByVal s As String) As Long
    s = Trim$(s)
    If s = "" Then Exit Function
    If Not IsNumeric(s) Then Exit Function
    SafeNum = CLng(Val(s))
End Function

Private Function GetDefaultPrinter() As String
    Dim wmi As Object, col As Object, p As Object
    On Error Resume Next
    Set wmi = GetObject("winmgmts:\\.\root\cimv2")
    Set col = wmi.ExecQuery("SELECT Name FROM Win32_Printer WHERE Default = True")
    For Each p In col
        GetDefaultPrinter = p.Name
        Exit For
    Next
End Function

Private Function SetDefaultPrinter(ByVal pName As String) As Boolean
    On Error GoTo Failed
    CreateObject("WScript.Network").SetDefaultPrinter pName
    On Error Resume Next
    Application.ActivePrinter = pName
    SetDefaultPrinter = True
    Exit Function
Failed:
    Err.Clear
End Function