第6回 新規文書に名前を付けて保存する
前回、
データ（笑）を差し込んで新規作成した文書について、コマンドボタンを置いた1ページ目を削除するところまで進みました。
今回は、この文書に名前を付けて保存する処理に進みます。
ファイル名を付けるに当たっては、データ（笑）元のテーブルの値を使うことにします。
目次
保存するファイルのフルパスを決定する
ファイルを保存するには、そのファイルのフルパスを決定する必要があります。
順に取得していきましょう。
保存先のフォルダパスを取得する
まず、フォルダのパスを取得します。
今回のプロジェクトでは、差し込み印刷用文書と同じフォルダに置いた「★作成した文書」フォルダに保存することとします。
差し込み印刷用文書、すなわち今回作成しているマクロを置いている文書のあるフォルダのパスは、
ThisDocument.Pathで取得することができます。
そのフォルダ直下にある「★作成した文書」フォルダなので、
ThisDocument.Path & "\★作成した文書\"とすればオッケーです。
ファイル名に使う値を取り出す
今回差し込み印刷に使うテーブルは、
| ID | Phrase |
|---|---|
| 1 | ほかにすることはないのですか。 |
| 2 | 成功です。ふふふ……。 |
| 3 | きっとうまくいくでしょう。 |
というものです。
Phraseカラムの値を文書に差し込むので、IDカラムの値をファイル名の連番に使うことにします。
1つ目のレコードを差し込んだファイルの場合、ファイル名を
諸葛亮曰く_01.docx
のように、IDカラムの値をゼロ埋め2けたの文字列にして、_（アンダースコア）とともに「諸葛亮曰く」の末尾に付けることにします。
Documentオブジェクトに接続している差し込みデータ用テーブルのレコードからIDカラムの値を取得するには、
DocumentオブジェクトのMailMergeプロパティを叩いてMailMergeオブジェクトを取得するMailMergeオブジェクトのDataSourceプロパティを叩いてMailMergeDataSourceオブジェクトを取得するMailMergeDataSourceオブジェクトのDataFieldsプロパティを叩いて、MailMergeDataFieldsコレクション・オブジェクトを取得するMailMergeDataFieldsコレクション・オブジェクトのItemメソッドにカラム名を渡す
このようにします。
リスト1
Private Sub ExportMailMergeDocuments()
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
mds.ActiveRecord = 1
mds.FirstRecord = 1
mds.LastRecord = 1
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
End Subこのコードの
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
mds.ActiveRecord = 1
mds.FirstRecord = 1
mds.LastRecord = 1
Call mm.Execute( _
Pause:=True _
)この部分で、差し込み印刷用文書を表すDocumentオブジェクトのMailMergeオブジェクトのExecuteメソッドによって1件目のレコードを闘魂注入しています。
変数mdsには、すでに差し込みデータ用テーブルの1件目のレコードが格納されていますので、
mds.DataFields.Item("ID")としてやれば、1件目のレコードのIDカラムの値である1が返ることになります。
したがって、「諸葛亮曰く_01.docx」という文字列を組み立てるには、
"諸葛亮曰く" & "_" & Format(mds.DataFields.Item("ID"), "00") & ".docx"とします。
保存するファイルのフルパスを作る
これで、保存するファイルのフルパスを組み立てる準備ができました。
リスト2
ソースコードを
Public Sub ExportMailMergeDocuments()
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
mds.ActiveRecord = 1
mds.FirstRecord = 1
mds.LastRecord = 1
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"
End Subこれで、
dirPath & tgtFilenameとすれば、保存するファイルのフルパスを取得することができます。
保存してファイルを閉じる
これで準備完了。まさに「時は来た！」状態です。
リスト3
ソースコードを
Public Sub ExportMailMergeDocuments()
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
mds.ActiveRecord = 1
mds.FirstRecord = 1
mds.LastRecord = 1
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"
' 文書を保存する
Call newDoc.SaveAs2( _
FileName:=dirPath & tgtFilename _
)
End Subこれで、文書がファイルとして指定したフォルダに保存されます。
このように、ウィンドウにファイル名が表示され、
「★作成した文書」フォルダにもファイルが保存されています。
あとは、保存した文書を閉じれば、とりあえず一連の処理が出揃ったことになります。
リスト4
ソースコードを
Public Sub ExportMailMergeDocuments()
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
mds.ActiveRecord = 1
mds.FirstRecord = 1
mds.LastRecord = 1
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"
' 文書を保存する
Call newDoc.SaveAs2( _
FileName:=dirPath & tgtFilename _
)
' 文書を閉じる
Call newDoc.Close( _
SaveChanges:=False _
)
End Subおわりに
ここまでで、
- データ（笑）を文書に差し込んで新規文書を作成し、
- 余計な部分を削除し、
- ファイル名を組み立てて、
- 所定のフォルダに保存し、
- 保存した文書を閉じる
という処理が出揃いました。
ただ、現時点では差し込むレコードを、テーブルの1件目のレコードに決め打ちにしている状態です。
次回は、上記コードを接続したテーブルのデータ（笑）の件数分ループする形に書き換えます。
関連記事
Click!!
