【連載】差し込み印刷のレコードごとにドキュメントを作成するマクロの解説（第7回）

第7回ループ処理に書き換える

ランキング参加中

プログラミング

前回

akashi-keirin.hatenablog.com

までで、ついに

データ（笑）を差し込んだ新規文書をちょっと手入れして名前を付けて保存する

という核心部分の処理が出来上がりました。

今回は、この処理をループ処理に書き換えます。

時は来た。それだけだ！

ループ回数の上限を求める

ここまで使ってきたコードでは、差し込み印刷用文書（sample.docm）に差し込むデータ（笑）は、

mds.ActiveRecord = 1
mds.FirstRecord = 1
mds.LastRecord = 1

このように、全部「1」。〝決め打ち〟でした。

しかしながら、差し込み印刷というものは、自動で全レコードを順に差し込んでくれるからありがたいのであって、手動で一つ一つレコードを指定しなくてはいけないのでは、オートフィーダーのあるコピー機で原稿を一枚一枚ガラスの上にセットするようなものです。

それではタンザニアのイカンガーでしょう。

そこで、For ... Nextループを使います。

ループの始点は`1`で良いとして、終点はどうするか。

答えは簡単です。差し込みデータ（笑）の件数にすれば良いですね。

このとき

そして、このおじさんが知っている差し込みデータ用のテーブル、すなわち文書に接続されているテーブルがMailMergeDataSourceオブジェクトです。

MailMergeDataSourceオブジェクトはおじさん、すなわちMailMergeオブジェクトにぶら下がっているオブジェクトです。

MailMergeDataSourceオブジェクトは、MailMergeオブジェクトのDataSourceプロパティを叩くことで取得することができます。

こう述べたように、差し込み印刷用文書（sample.docm）に接続されているソースデータを表すMailMergeDataSourceオブジェクトは、文書本体を表すDocumentオブジェクトにぶら下がっているMailMergeオブジェクトにぶら下がっていますので、

Dim doc As Document
Set doc = ThisDocument
Dim mm As MailMerge
Set mm = doc.MailMerge
mm.Destination = wdSendToNewDocument
mm.SuppressBlankLines = True
Dim mds As MailMergeDataSource
Set mds = mm.DataSource

このように、MailMergeオブジェクトのDataSourceプロパティを叩いてやれば取得することができます。

このMailMergeDataSourceオブジェクトが何件のレコードを持っているのか調べるには、コチラにあるように、RecordCountプロパティを叩きます。

したがって、変数mdsにMailMergeDataSourceオブジェクトが格納されているとすると、

Dim recCnt As Long
recCnt = mds.RecordCount

としてやれば、変数recCntにレコード件数を突っ込むことができます。

これであとは、

Dim i As Long
For i = 1 To recCnt

Next

というブロック内に、データ（笑）を差し込んで新規文書を整えて名前を付けて保存する処理を入れ込むだけです。

時は来た。それだけだ！

Forブロックに処理を入れ込む

では、前回までのコードをFor ... Nextに入れ込みます。

リスト1

Public Sub ExportMailMergeDocuments()
    ' Documentオブジェクト取得
    Dim doc As Document
    Set doc = ThisDocument
    ' MailMergeオブジェクト取得
    Dim mm As MailMerge
    Set mm = doc.MailMerge
    ' MailMergeオブジェクトの初期設定
    mm.Destination = wdSendToNewDocument
    mm.SuppressBlankLines = True
    ' MailMergeDataSourceオブジェクト取得
    Dim mds As MailMergeDataSource
    Set mds = mm.DataSource
    ' レコード数取得
    Dim recCnt As Long
    recCnt = mds.RecordCount
    
    ' Forループで差し込み→ファイル作成
    Dim i As Long
    For i = 1 To recCnt
        ' 差し込むレコードと始点・終点をセット
        mds.ActiveRecord = i
        mds.FirstRecord = i
        mds.LastRecord = i
        ' You 差し込みやっちゃいなよ
        Call mm.Execute( _
            Pause:=True _
        )
        ' 生み出された新規文書を即取得
        Dim newDoc As Document
        Set newDoc = Application.ActiveDocument
        ' 文書末尾の余分なセクション区切りをポア
        Dim lastSection As Section
        Set lastSection = newDoc.Sections(newDoc.Sections.Count)
        If lastSection.Range.Start = newDoc.Content.End - 1 Then
            Call lastSection.Range.Previous(Unit:=wdCharacter, Count:=1).Delete
        End If
        ' 今となっては不要の先頭ページもポア
        ' （狡兎死して走狗烹らる）
        Call newDoc.Range(0, 0).Select
        Dim firstPageRng As Range
        Set firstPageRng = newDoc.Bookmarks.Item("\Page").Range
        Call firstPageRng.Delete
        ' 保存用のファイルパスを組み立てる
        Dim dirPath As String
        dirPath = ThisDocument.Path & "\★作成した文書\"
        Dim tgtFilename As String
        tgtFilename = "諸葛亮曰く" & "_" & Format(mds.DataFields.Item("ID"), "00") & ".docx"
        ' You、保存、やっちゃいなよ
        Call newDoc.SaveAs2( _
            FileName:=dirPath & tgtFilename _
        )
        ' 保存した文書を閉じる
        Call newDoc.Close( _
            SaveChanges:=False _
        )
    Next
End Sub

処理の段階ごとにコメントを付けておきました。

エラー対応などは一切ない骨組みだけのコードですが、必要な機能は揃っています。