【Word VBA】差し込み印刷でレコード毎に別ファイルで保存するWordマクロ(その3)

これまでに、「【コード】差し込み印刷でレコード毎に別ファイルで保存」と「【コード】差し込み印刷でレコード毎に別ファイルで保存(その2)」を紹介してきました。

今回の改良で、チェックしたレコードのみを処理対象にできるようにしました。

ぜひお試しください。

このマクロでできること

差し込み印刷の対象としてチェックをつけたレコードだけを処理対象にします。チェックがないレコードはスキップされます。以下、Excelブックに入力したサンプルの名簿でレコードが選択されている状態を示しています。

作成するWord文書のファイル名をフィールドから指定できます。これまでのマクロでは、プログラム中に記述しましたが、今回は実行前にインプットボックスで指定します。

たとえばここでデータの中のフィールドの1つである「名前」と入力すると、この名前を用いてファイル名を作成します。先頭には通し番号が挿入されます。

マクロの解説

ファイル名に使用するフィールドを指定する

10行目~16行目で設定しています。

86行目以降に書かれているIsValidFieldNameファンクションを使い、入力したフィールド名が差し込み印刷のデータで実際に定義されているフィールドなのかを確認します。

チェックしたレコードのみを処理対象にする

実は、今回のマクロでDataSource.Includedプロパティを使い、チェックの入ったレコードのみを処理対象にしようとしましたが、うまくできませんでした。まだオブジェクトの仕組みを正確に理解できておりません。

なので、今回はエラー処理で切り抜けることにしました。

チェックが入っていないレコードを差し込み印刷しようとするとエラーが発生します。なので、エラーが発生しないときだけファイルを作成し(50行目~69行目)、エラーが発生したらエラーを解除して(71行目~76行目)次のレコードに進むという流れです。

マクロ


Sub 差し込み印刷_レコード毎に別ファイルで保存3()
 
 Dim myMainDoc As Document: Set myMainDoc = ActiveDocument
 
 With myMainDoc.MailMerge
  
  '-------------------------------------------
  'ファイル名の指定
  '-------------------------------------------
  Dim myFieldName As String
  myFieldName = InputBox("ファイル名に使用するフィールド名を入力してください。", _
              "ファイル名の設定")
  If IsValidFieldName(.DataSource.FieldNames, myFieldName) = False Then
   MsgBox "フィールド名が間違っています", vbExclamation
   Exit Sub
  End If
  
  '-------------------------------------------
  '差し込み印刷の設定
  '-------------------------------------------
  '新規文書に書き出す
  .Destination = wdSendToNewDocument
  
  '空白の差し込みフィールドを印刷しない
  .SuppressBlankLines = True
  
  '-------------------------------------------
  '本処理
  '-------------------------------------------
  Dim i As Integer    'レコード番号
  
  Dim iMax As Integer   '対象となる最終レコード番号(レコード数ではない)
  .DataSource.ActiveRecord = wdLastRecord
  iMax = .DataSource.ActiveRecord
  
  Dim j As Integer: j = 0 '作成したファイルの通し番号
  
  For i = 1 To iMax '全レコードを対象にループ処理
   
   'レコードの指定(1つのレコードに限定)
   With .DataSource
    .FirstRecord = i
    .LastRecord = i
    .ActiveRecord = i
   End With
 
   On Error Resume Next
   .Execute
   
   If Err = 0 Then
    '-------------------------------------------
    'レコードが対象として選択されている場合:差し込み印刷を実行
    '-------------------------------------------
    j = j + 1
    
    Dim myFileName As String: myFileName = .DataSource.DataFields(myFieldName).Value
    If myFileName = "" Then myFileName = "★" & myFieldName & ":不明★"
    myFileName = j & "_" & myFileName 'ファイル名:通し番号+指定したフィールドの値
    
    '新規文書に名前をつけてdocx形式で保存
    Dim myNewDoc As Document: Set myNewDoc = ActiveDocument
    
    myNewDoc.SaveAs FileName:=myMainDoc.Path & "\" & myFileName & ".docx", _
            FileFormat:=wdFormatXMLDocument, _
            AddToRecentFiles:=False
    myNewDoc.Close
    DoEvents
    
    Set myNewDoc = Nothing
    
   Else
    '-------------------------------------------
    'レコードが対象として選択されていない場合:エラー発生
    '-------------------------------------------
    Err.Clear
   End If
   
  Next i
  
 End With
 
 Set myMainDoc = Nothing
 
End Sub

Function IsValidFieldName(myFieldNames As Object, myFieldName As String) As Boolean

 IsValidFieldName = False
 Dim myName As Object
 For Each myName In myFieldNames
  If myName.Name = myFieldName Then
   IsValidFieldName = True
   Exit For
  End If
 Next
 
End Function

関連記事

【コード】差し込み印刷でレコード毎に別ファイルで保存

【コード】差し込み印刷でレコード毎に別ファイルで保存(その2)

トップへ戻る