フォルダ構成を別のフォルダにコピーするマクロ(3)
一覧表のデータを元にフォルダ構成を移植する
いよいよ今回のマクロも完成。
今回は、前回のマクロで作成したフォルダの一覧表を元に、別のフォルダにフォルダ構成を再現する処理を書いていく。
処理の下準備
リスト1-1
Sub moveFolderStructure()
Dim objSh As Worksheet
Set objSh = ActiveSheet
With objSh
If .Range("A3").Value = "" Then '……(1)'
MsgBox "フォルダフルパスが空白なので処理できません。", vbCritical
Exit Sub
End If
Dim lastRw As Integer
lastRw = .Cells(Rows.Count, 1).End(xlUp).Row '……(2)'
End With
リスト1-1の説明
処理を始めるための準備みたいなところ。
- (1)は、Ａ３セルが空白かどうかで条件分岐。Ａ３セルに何も入っていなければ、そもそもフォルダ構成が取得できていないということなので、メッセージを表示して処理を終える。
- (2)はおなじみ、データのある最終行番号を求める計算。データ転記系の処理ではマジでよく使うので、入門者は理屈とともに手が勝手に動くレベルまで習熟すべし。
コピー先の親フォルダのフルパス取得
当ブログではもはやおなじみ、FolderPickerクラスを使う。
リスト1-2
Dim rootPath As String
Set fldPicker = New FolderPicker '……(1)'
MsgBox "フォルダ構成のコピー先となる親フォルダを指定せよ。"
With fldPicker
.showFolderPicker '……(2)'
If .isCancelled = True Then '……(3)'
Exit Sub
End If
rootPath = fldPicker.gotFolder '……(4)'
End With
リスト1-2の説明
もはや説明不要かも知れんけど、一応。
- (1)はおなじみ、FolderPickerクラスをインスタンス化。ひつこいようだけど、ここから先は変数fldPickerをさながらフォルダパス等の取得屋さんのように使える。
「fldPickerさ～ん、ちょっとフォルダ選択ダイアログを表示して～！」とか、「fldPickerさ～ん、フォルダのフルパスを教えて～！」みたいな感じ。クラスを作るメリットの一つだと思う。 - (2)がまさに「fldPickerさ～ん、ちょっとフォルダ選択ダイアログを表示して～！」。
- (3)の「fldPicker.isCancelled」の取得は「fldPickerさ～ん、キャンセルされた？」てな感じ。
- (4)は、さしづめ「fldPickerさ～ん、ちょっと選択されたフォルダのフルパスを教えて？ rootPathに代入すっからさ！」てな感じかな。
「クラス」というものを使うと、まるでオブジェクトと会話するような感じでプログラミングできる、というメリットがある。もちろん、クラス名やフィールド名、メソッド名を適切につけた場合に限るんだろうけど。
フォルダ構成の複製
いよいよここからがメインの処理。
リスト1-3
Dim i As Integer '……(1)'
Dim n As Integer '……(2)'
Dim strPath As String '……(3)'
With ObjSh
For i = 3 To lastRw '……(4)'
n = 2 '……(5)'
strPath = .Cells(i, n).Value '……(6)'
Do While .Cells(i, n).Offset(0, 1).Value <> "" '……(7)'
strPath = strPath & "\" & _
.Cells(i, n).Offset(0, 1).Value '……(8)'
n = n + 1 '……(9)'
Loop
strPath = rootPath & "\" & strPath '……(10)'
If Dir(strPath, vbDirectory) = "" Then '……(11)'
MkDir strPath '……(12)'
End If
Next
End With
MsgBox "フォルダ構成の複製が終わりました。"
End Sub
リスト1-3の説明
- (1)でループカウンタ i を宣言。一覧表を行方向に進んでいくのに使う。
- (2)でループカウンタ n を宣言。コチラは、一覧表を列方向に進んでいくのに使う。
- (3)は、フォルダパスを格納するのに使う変数。
- (4)は、行方向のループ設定。３行目から最終行まで回す。
- (5)で n の初期値を設定。今回使用するワークシートでは、Ａ列、すなわち１列目には元のフォルダのフルパスが入っている。個々のフォルダ名は２列目以降に入っているので、n の初期値は 2 となる。
- (6)で、まず i 行目の１つ目（Ｂ列）のフォルダ名をstrPathに格納。
- (7)は、(7)からの５行（実質４行）のDoループの継続条件。１つ右のセルが空白になるところまで右へ右へ進んでいくイメージ。
- (8)では、１つ右のセルに入っているフォルダ名を、アタマに「\」をつけてstrPathに連結している。
たとえば、strPathに「A」、１つ右のセルに「B」が入っていたら、この段階でstrPathの中身が「A\B」（＝Aフォルダの中にあるBフォルダ）になっているということ。 - (9)で n をインクリメント。
- (7)のDoループを抜けた段階で、strPathにはサブフォルダのフォルダパスが格納されているので、あとは(10)で、そのアタマに、移動先のフォルダパスと「\」を連結してやれば、サブフォルダのフルパスができる。
- (11)で既にそのフォルダがあるかどうかを判定し、なければ(12)のMkDirステートメントで作成する。
あとは、 i が最終行番号に達するまで繰り返す。こうすることで、新たにフォルダ構成だけを指定のセルに書き込むことができる。
実行
ボタンをクリックしてマクロ起動。
フォルダを選べ、と言われるので、
フォルダを選択すると、
あっという間に完了。
「ち～んｗ」フォルダ内にフォルダができている。Bフォルダの中にC、Dフォルダがあることが分かる。Eフォルダもある。
おわりに
同じフォルダ構成を繰り返し用いる業務があるなら、ファイルはコピーせずにフォルダ構成だけを複製することができるこのマクロはなかなか便利だと思う。
フォルダ構成を別のフォルダにコピーするマクロ(2)
指定したフォルダ内のフォルダ構造をワークシートに書き出す
標準モジュールの宣言セクション
リスト1-1
Option Explicit Dim fldPicker As FolderPicker
おなじみ、変数宣言の強制と、FolderPickerクラスのインスタンス用の変数宣言。FolderPickerクラスについては、コチラをどうぞ。
セルのクリアとラベルの書き込み
リスト1-2
Sub copyStructureFromOrg()
Dim objSh As Worksheet
Set objSh = ActiveSheet '……(1)'
With objSh
.Cells.ClearContents '……(2)'
.UsedRange.Borders.LineStyle = xlNone '……(3)'
.Range("A2").Value = "フォルダフルパス" '……(4)'
.Columns("A").ColumnWidth = 40 '……(5)'
End With
リスト1-2の説明
- (1)で、アクティブシートをオブジェクト変数にセット。
- (2)で一旦全てのセルの内容をクリア。
- (3)で全ての罫線をクリア。こういうときにはUsedRangeプロパティが便利。
ちなみに、UsedRangeは文字通り使用中のセル、Bordersはセルの境界線のコレクションで、「セルの辺みんな」ぐらいの理解でいいと思う。 - (4)でＡ２セルに「フォルダパス」と書き込んでいる。シートの２行目はラベル領域なんだけど、この程度なら毎回書き直しても大した手間ではないので、一旦消してから毎回書き込むようにしている。
- (5)で、Ａ列の列幅を「40」にしている。まあ、「40」という数字に深い意味はない。
フォルダ構成コピー元フォルダの指定
FolderPickerクラスを使う。
リスト1-3
With objSh
Set fldPicker = New FolderPicker '……(1)'
MsgBox "フォルダ構成のコピー元となる親フォルダを指定せよ。"
With fldPicker
.showFolderPicker "フォルダ選択( ﾟ∀ﾟ)" '……(2)'
If .isCancelled = True Then '……(3)'
Exit Sub
End If
Dim rootPath As String
rootPath = fldPicker.gotFolder '……(4)'
objSh.Range("C1").Value = "←元の親フォルダ名"
objSh.Range("B1").Value = .gotFolderName '……(5)'
End With
End With
リスト1-3の説明
- (1)で、FolderPickerクラスをインスタンス化。以降、変数fldPickerでFolderPickerオブジェクトを操作することができる。
- (2)で、FolderPickerオブジェクトのshowFolderPickerメソッドを実行。引数に「フォルダ選択( ﾟ∀ﾟ)」という文字列を渡しているので、フォルダ選択ダイアログボックスのタイトル部分には「フォルダ選択( ﾟ∀ﾟ)」が表示される。
- (3)でフォルダ選択がキャンセルされたかどうか判定。キャンセルされるか、フォルダを選択せずに[ＯＫ]をクリックしていると、FolderPickerオブジェクトのisCancelledプロパティがTrueになっている。Trueだったらこのプロシージャから抜けるようにしている。
- (4)では、取得したフォルダパスを変数rootPathにセットしている。showFolderPickerメソッドの実行によりフォルダパスが取得できていたらgotFolderプロパティにフォルダのフルパスがセットされている。
- (5)でシートのＢ１セルにフォルダ名を書き込んでいる。gotFolderNameプロパティにはフォルダ名のみの文字列がセットされている。
全てのサブフォルダのフルパスをＡ列に書き込む
前回紹介したwriteAllFolderPathメソッドの出番。
リスト1-4
Call writeAllFolderPath(rootPath)
リスト1-3の(4)で取得したrootPathを引数として渡してwriteAllFolderPathメソッドを実行。
Ｂ列以降にサブフォルダ名を階層に分けて書き込む
リスト1-5
Dim lastRow As Integer
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row '……(1)'
Dim i As Integer '……(2)'
Dim arryPath As Variant '……(3)'
Dim n As Integer '……(4)'
Dim objStr As String
With ObjSh
For i = 3 To lastRow
objStr = Replace(.Cells(i, 1).Value, rootPath & "\", "", _
Compare:=vbTextCompare) '……(5)'
arryPath = Split(objStr, "\") '……(6)'
For n = 0 To UBound(arryPath) '……(7)'
.Cells(i, n + 2).Value = arryPath(n) '……(8)'
Next n
Next i
End With
リスト1-5の説明
- (1)はおなじみの書き込み済み最終行番号の取得。
- (2)の「i」はループカウンタ。この後の処理で書き込み対象行番号を指すのに使う。
- (3)は、フォルダ名を階層ごとに格納するのに使う配列。
- (4)の「n」もループカウンタなんだけど、こっちは書き込み対象列番号を指すのに使う。
- (5)は、Replace関数を用いて、フォルダのフルパスからリスト1-3の(4)で取得したrootPathを除いた文字列を変数objStrにセットしている。
指定したフォルダよりも下層にあるフォルダ構成をコピーする、という処理内容なので、指定したフォルダまでのパスは必要ないのでこうしている。
あと、Replace関数の引数CompareにvbTextCompareを指定しているのがポイント。こうしておかないとReplace関数がネットワークドライブのドライブ名の大文字を勝手に小文字に変換してしまうのでうまくいかなかった。 - (6)では、Split関数を用いてフォルダ内各階層のフォルダ名を配列として取得。要素数が流動的なので、(3)でVariant型にしていたということ。
- だから、(7)でForループの最終値をしていするのもUbound関数を使う。
- ここまで準備をしたら、あとは(8)で、列番号（マイナス2）を表すループカウンタ「n」と、行番号を表すループカウンタ「i」を利用して各階層のフォルダ名をセルに書き込んでいく。
階層の深さに応じて右へ右へ書き込んで行き、最下層のフォルダ名まで書き込んだら次の行へ移る、というイメージ。
ラベル書き込みとセルの並べ替え
リスト1-6
Dim maxCol As Integer
Dim objCell As Range
For i = 3 to lastRow '……(1)'
'i行目の列数を割り出す'
n = 1
Do While .Range("A" & i).Offset(0, n).Value <> "" '……(2)'
n = n + 1
Loop
If maxCol < n Then '……(3)'
maxCol = n
End If
Next
'2行目に列ラベルを書き込む'
With objSh
For n = 2 To maxCol '……(4)'
.Cells(2, n).Value = "第" & n - 1 & "階層" '……(5)'
.Cells(2, n).HorizontalAlignment = xlCenter '……(6)'
.Cells(2, n).Borders.LineStyle = xlContinuous '……(7)'
Next
End With
リスト1-6の説明
- (1)では、Ａ列の３行目～記入済み最終行までForループを指定。
- (2)からの３行は、Ａ列から数えてn番目のセルが空白になるまで「n」をインクリメントする処理。
こうすることで、Doループを抜けたときには変数nがi行目の「データの入っている最終列番号」になる。
たとえば、Ｃ列までデータが入っていたとすると、n = 1でＢ列→ n = 2でＣ列 → n = 3 で空白のＤ列にたどり着いてループから抜けるので、ループから抜けた時点で n は 3、すなわちＣ列を表すということになる。 - (3)で n がそれまでのmaxColを上回っていればmaxColを n の値で更新する。
これを i がlastRowになるまで繰り返せば、Forループが終わった段階でmaxColには最も階層が深いフォルダの階層数が入っていることになる。 - ここまでの処理で最大行数と最大列数が確定するので、(4)以降のループ処理に移る。
- (5)で２行目の各列にラベル名を書き込む。
- (6)では２行目各列の文字の配置を中央揃えに。
- (7)でlastRow行×maxCol列の範囲に格子状罫線を施している。
最大行数×最大列数のセル領域のうち、空白セルに「0」を書き込む
この後の処理で並べ替える際に、空白セルがあると一番下になってしまう。それを避けるため、一旦空白のセルに全て「0」を書き込むことにする。
リスト1-7
With objSh
Dim objRange As Range
Set objRange = Range(.Cells(3, 1), .Cells(lastRw, maxCol)) '……(1)'
For Each objCell In objRange '……(2)'
If objCell.Value = "" Then
objCell.Value = "0"
End If
Next
End With
リスト1-7の説明
- (1)で変数objRangeに各階層のフォルダ名を書き込んだセル範囲をセット。
- (2)では、おなじみのFor Each～Nextを用いて各セルを調べ、空白なら「0」を書き込む。
右端の列から昇順ソートし、一旦「0」にしたセルを空欄に戻す
右端の列から順に昇順ソートすることにより、何列あったとしても並べ替えの優先度を「左端の列→右端の列」にすることができる。
リスト1-8
For i = maxCol To 2 Step -1 '……(1)'
objRange.Sort key1:=.Cells(3, i), _
order1:=xlAscending
Next
For Each objCell In objRange
If objCell.Value = "0" Then
objCell.Value = "'0" '……(2)'
objCell.Value = ""
End If
Next
リスト1-8の説明
- (1)だが、先にも書いたとおり並べ替えの優先度の低い方から順に並べ替えをしていくことで、列数にかかわらずうまく並べ替えることができる。
- おなじみ、For Each～Nextなんだが、単純に各セルに""を書き込むだけだとなぜかセルの値が「0」扱いになり、(2)のように一旦「'」を付けて文字列にしてから""を書き込むとうまくいった。なぜだかよく分からない。
格子罫線を引いて列幅を調整
リスト1-9
With objSh
objRange.Borders.LineStyle = xlContinuous '……(1)'
.Range("A2").Borders.LineStyle = xlContinuous '……(2)'
.Range(.Columns(2), .Columns(maxCol)).AutoFit '……(3)'
End With
MsgBox "全てのフォルダ構成が書き出されました。"
End Sub
リスト1-9の説明
- (1)で範囲内に格子罫線を施す。
- (2)では同じくＡ２セルに格子罫線を施す。
- (3)ではＢ列～最終列までの列幅を自動調整している。
実行結果
実行すると、
こんな具合にフォルダ構成が階層ごとに書き出される。
この程度ならあんまりありがたみもないんですが、
このぐらいのフォルダ数になると、かなり便利だと感じると思う。
次回予告
後は、書き出したフォルダ構成を別のフォルダに移植する処理を追加したらできあがり。お楽しみに！
フォルダ構成を別のフォルダにコピーするマクロ(1)
全てのサブフォルダのパスを書き出す
「再帰呼び出し」を使ったコード
フォルダの中にフォルダがあって、そのフォルダの中にまたフォルダがあって……というような場合に、全てのフォルダのパスを取得するためには、メソッドの「再帰呼び出し」というものを使えば良いらしい。
参考にしたのは、日経ソフトウエア誌2015年10月号の「実務で使うExcelVBA」。VBA界では超有名な武藤玄さんによる連載記事。
「日経BPパソコンベストムック」シリーズのいますぐExcelVBAが使えるようになる本にも載っている。今でもフツーに手に入ると思う。
では、コードをば。
リスト１
Sub writeAllFolderPath(ByVal basePath As String)
Dim objSh As Worksheet
Set objSh = ActiveSheet
Dim objSubFolder As Object '……(1)'
Dim objRow As Integer
For Each objSubFolder _
In CreateObject("Scripting.FileSystemObject") _
.GetFolder(basePath).SubFolders '……(2)'
Call writeAllFolderPath(objSubFolder.Path) '……(3)'
objRow = objSh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row '……(4)'
objSh.Range("A" & objRow).Value = objSubFolder.Path
Next
End Sub
コードの説明
自身の復習も兼ねて、ちょっとこってり説明しておこう。
そもそも、「FileSystemObjectオブジェクト」ってなんだかよく分からなかったんですよ。
名前からしてわけ分からないじゃないですか。ほれ、「ファイルシステムオブジェクトオブジェクト」って、「大瀬ゆめじ・うたじ・うたじ」（ナイツのネタ）みたいで。
でもまあ、オブジェクト指向とかが分かってきはじめた今なら、ちゃんと理解できるんじゃないかと説明を試みることにします。
まずはコイツ。
リスト１の(1)
Dim objSubFolder As Object
「FileSystemObject」オブジェクトってのは、「ファイルシステムに関するアレ」みたいなふうにとらえたらいいのかな。それこそ「フォルダ」とか、「ドライブ」とか、「ファイル」とかいう、データを管理するためのもろもろのアレ。そういう概念を「FileSystemObject」オブジェクトっていうんだと思っている。
当然、Excelにはそんなデータ型は存在しないから、Object型のオブジェクト変数にしとるわけだ。
んで、次。
リスト１の(2)
For Each objSubFolder _
In CreateObject("Scripting.FileSystemObject") _
.GetFolder(basePath).SubFolders
Next
１行がやたら長くなるので行継続文字を使っている。「For」～「SubFolders」までが長～い１行。
よく見かけるのは次のような書き方。
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
With FSO.GetFolder(basePath)
For Each objSubFolder In .SubFolders
End With
まあ、単にまずFileSystemObjectオブジェクト自体をインスタンス化して変数にセットしてから使っているだけ。FileSystemObjectオブジェクトを後ほど使い回す必要があるんなら、変数にセットした方が使い勝手が良い、というだけだと思う。
とにかく、
CreateObject("Scripting.FileSystemObject").GetFolder(basePath).SubFolders
の部分の処理の順番としては、
- FileSystemObjectオブジェクトをインスタンス化
- GetFolderメソッドに、引数（この場合は「basePath」というフォルダパス）を渡して、そのフォルダパスが指し示すFolderオブジェクト（要するに「フォルダ」そのもの）を取得（参考１・参考２）
- SubFoldersプロパティで「2.」で取得したフォルダ内の全てのサブフォルダをコレクションとして取得（参考）
ということだな（間違ってたら教えてくれください）。
これをFor Each ～ Nextで回すわけだから、要するに、
引数basePathが指すフォルダ内のサブフォルダを一つづつ変数objSubFolderにセットして処理を繰り返す
ことになる。
リスト１の(3)
ここが最大のポイント。メソッドが自分自身を呼び出す。これが「再帰呼び出し」ですね。英文法で自分自身を指し示す「myself」のことを「再帰代名詞」と呼ぶのと同じ。斉木しげるとは関係ない。
Call writeAllFolderPath(objSubFolder.Path)
変数objSubFolderには既にFolderオブジェクトが入っているわけだが、そのFolderオブジェクトのPathプロパティ（要するにフォルダのフルパスね）を引数としてwriteAllFolderPathメソッドを呼ぶ。
そうすると、今objSubFolderに入っているフォルダのさらにサブフォルダをコレクションとして取得して……となるわけ。
これ読んで、処理の流れを頭の中だけで理解できる人いるのかな？？？
というわけで、ちょっと寄り道して処理の流れを見ていこう。
その前にリスト１の(4)の処理だけ見ておく。
リスト１の(4)
objRow = objSh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
objSh.Range("A" & objRow).Value = objSubFolder.Path
これは簡単。単に、シートのＡ列書き込み済み最終行の次の行番号を取得して、そこに変数objSubFolderに格納されているフォルダのフルパスを書き込んでいるだけ。ちょっとくどいかも知れんけど、
CreateObject("Scripting.FileSystemObject").GetFolder(basePath).SubFolders
で取得したサブフォルダのフルパスをその都度シートのＡ列に書き込んで追加しているだけだ。
再帰呼び出しの挙動
例として、次のような構成のフォルダを作る。
要するに、次のようなフォルダ構成。
実行
ループに突入した直後のobjSubFolderの中身は、
この通り、「フォルダB」。で、「フォルダB」のフルパスを渡してwriteAllFolderPathを呼び出すと、
当然objSubFolderの中身は「フォルダC」。んで、さらに「フォルダC」のフルパスを渡してwriteAllFolderPathを呼び出すと、
今度はもうサブフォルダがないからobjSubFolderはNothingになる。
この段階でやっとここに処理が移る。
シートにフォルダのフルパスが書き込まれた。で、次のループ。
「フォルダB」配下のSubFolderコレクションのうち、「フォルダC」の処理が終わったので、次の「フォルダD」がobjSubFolderに格納されているのが分かる。
実行結果
全てのフォルダパスが書き出された。
おわりに
なんだか、頭がこんがらがってくるんだけど、ステップ実行しながら挙動を確認したら理解はできると思う。
このメソッドを用いて、フォルダ構成をまるごと別のフォルダにコピーするマクロを完成させていく。
新年度を迎えて、自分の担当業務用のフォルダを丸ごと移したい。だけど、中のファイルはいらない
というときに役に立つと思う。
Word 差込印刷のレコードごとにファイルを生成するマクロ
Wordの差込印刷でレコードごとにファイルを保存
普段、仕事で差込印刷をよく使うんだが、「レコードごとに別々のファイルにしてくんねーかなー」と思っていた。
以前は、
- 一旦、PDFにする
- １ページづつバラす
- それぞれにファイル名をつける
というおっそろしくメンドクサイことをしていたが（まあ、他の人が１個づつファイルを作っているのに比べたらそれでもだいぶ効率的なんですけど）、ggりまくって次のページにたどり着いた。
参考サイト１
「みんなのワードマクロ」様。
コチラのサンプルコードは、差込印刷のレコードごとに新しいドキュメントを生成していく、というもの。
これだよ、これ！ まさにこういうのが欲しかったんだよ！
という言葉しかございません。
差込印刷がMailMergeオブジェクトを使うんだなんて、いったいどうやってたどり着いたんだろ？
ただただすげえな、と思うばかり。
参考サイト２
VBA界では超有名な「インストラクターのネタ帳」様。
コチラのページからは、アクティブなページを削除するというワザを拝借しました。
標準モジュールのコード
ほとんど丸ごといただいたみたいなコードですが、めちゃ便利なので載っけときます。
Const FOLDER_NAME As String = "★作成した文書" 'フォルダ名を変えたらここを変えること。'
Sub insertionPrintAndCreateNewDoc()
If Dir(ThisDocument.Path & "\" & FOLDER_NAME, vbDirectory) = "" Then '……(1)'
Call MkDir(ThisDocument.Path & "\" & FOLDER_NAME)
Call MsgBox("作成済みファイルを保存するフォルダ「" & FOLDER_NAME & _
"」を、このファイルのあるディレクトリに作成しました。", vbInformation)
End If
Dim folderPath As String
folderPath = ThisDocument.Path & "\" & FOLDER_NAME & "\"
Dim baseDoc As Document '……(2)'
Dim newDoc As Document '……(3)'
Set baseDoc = ThisDocument '……(4)'
On Error GoTo HandleError
With baseDoc.MailMerge
Dim maxRec As Integer
maxRec = .DataSource.RecordCount '……(5)'
.Destination = wdSendToNewDocument '……(6)'
.SuppressBlankLines = True
Dim i As Integer
For i = 1 To maxRec '……(7)'
With .DataSource
.ActiveRecord = i '……(8)'
.FirstRecord = i
.LastRecord = i
End With
Call .Execute(Pause:=True)
DoEvents '……(9)'
Set newDoc = ActiveDocument
Dim tgtFileName As String
tgtFileName = .DataSource.DataFields("卒業期").Value & "期 " & _
.DataSource.DataFields("選手名").Value '……(10)'
If tgtFileName <> "" Then
Call newDoc.Bookmarks("\Page").Range.Delete '……(11)'
Call newDoc.SaveAs( _
fileName:=folderPath & tgtFileName & ".docx", _
fileformat:=wdFormatXMLDocument, _
addtorecentfiles:=False) '……(12)'
Call newDoc.Close
End If
DoEvents
Next
End With
Set baseDoc = Nothing
Set newDoc = Nothing
Exit Sub
HandleError:
Call MsgBox("エラーが発生しました。差込設定を見直すなど、設定を再確認してください。", vbExclamation)
End Sub
コードの説明
- (1)は、よくやるやつ。新しくできるファイルを保存するフォルダの有無を調べて、なかったら作る。
- (2)は、元のWordドキュメントを格納する変数。
- (3)は、新しくできるドキュメントを格納する変数。
- (4)で、マクロを書いているこのドキュメントを変数baseDocに格納。
- (5)で、変数maxRecにレコード数を格納。MailMerge.DataSourceオブジェクトのRecordCountプロパティから取得できる。
- (6)で、MailMergeオブジェクトのDestinationプロパティに定数wdSendToNewDocumentをセットしている。この定数をセットすると、とにかくこういうことになるらしいよ。
- (7)で、レコード数ぶんForループ。
- (8)からの３行。DataSourceオブジェクトのActiveRecord、FirstRecord、LastRecordの全てに同じ数字をセットすることで、１レコード１文書にしているのだと思う。
- (9)。よく分からんのだが、ここにDoEventsを入れていなかったら、ひたすら白紙文書がレコード数ぶん生産される。
- (10)で、新しくできるドキュメントのファイル名を作成。DataField(フィールド名)オブジェクトのValueプロパティを使えば、当該レコードのフィールドの文字列を呼んでくることができる。
- (11)で、最初のページを削除している。イマイチ理屈が分からんのだが。Bookmarksコレクションってのがあるんでしょうな。すまん、勉強不足で。（＊）
- (12)では、SaveAsメソッドを用いて新しくできたドキュメント（「定型書簡○○」って名前になっている）に名前を付けて保存している。
実行
差込データソースはこんな風に作っておいた。
差込フィールドは、ドキュメントの２ページ目に、こんな風に設定。
１ページ目には、こんな風にコマンドボタンを置いておいて、
ThisDocumentモジュールに、
Private Sub CommandButton1_Click() Call insertionPrintAndCreateNewDoc End Sub
こんな風にコードを書いておく。
ボタンを押すと、
保存用フォルダが作られて、
こんな風にファイルが作られる。
試しに一つ開いてみると、
こんな感じ。
おわりに
ほとんど借り物みたいなコードですが、めちゃくちゃ便利で重宝しております。
追記
コチラもどうぞ！
さらに追記
写しPDF作成マクロ～(4)
クラスを組み合わせる
使用したクラス
それぞれのクラスの詳細については、リンク先をどうぞ。
標準モジュールのコード
Option Explicit
Public Type myFolder
fdPath As String
fdName As String
fdIsExist As Boolean
fdIsCreated As Boolean
End Type
Public Const SAVE_FOLDER As String = "写しPDF"
Public fng As FileNameGetter
Public scm As StampedCopyMaker
Public fc As FolderCreator
Public dpc As DocPdfConverter
Public ec As ErrorCatcher
Public Sub voidMain()
Set scm = New StampedCopyMaker
With scm
'Wordドキュメントをセットする
.setDocument (Range("DocumentPath").Value) '……(1)'
If .isFailed = True Then '……(2)'
Call showFailure(.objWord, .objDoc, .causeOfFail) '……(3)'
Exit Sub
End If
'写しハンコを捺す
.createCopyWithStamp (Range("ImageFilePath").Value) '……(4)'
If .isFailed = True Then '……(5)'
Call showFailure(.objWord, .objDoc, .causeOfFail)
Exit Sub
End If
'PDF保存用のフォルダの有無をチェックし、なければ作る
Set fc = New FolderCreator
fc.createFolder scm.objDoc.path, SAVE_FOLDER '……(5)'
If fc.objFolder.fdIsCreated = True Then '……(6)'
.objWord.Visible = False
MsgBox "このフォルダ内に「" & SAVE_FOLDER & "」フォルダを作成しました。", _
vbInformation
End If
If fc.hasError = True Then '……(7)'
Set ec = New ErrorCatcher
ec.showError "FolderCreatorクラスのcreateFolderメソッド", True '……(8)'
Set ec = Nothing
End If
Set fc = Nothing
'WordドキュメントをPDF化して保存する
Set dpc = New DocPdfConverter
dpc.convertDocToPDF .objDoc, SAVE_FOLDER, "【写】" '……(9)'
Set dpc = Nothing
'元のWordドキュメントを閉じてWordを終了
.objWord.Visible = False
.objDoc.Close False
If .objWord.Documents.Count = 0 Then
.objWord.Application.Quit
End If
MsgBox "写しPDFを作成し、「写しPDF」フォルダに保存しました。"
End With
Set scm = Nothing
End Sub
Public Sub showFailure(ByRef wd As Word.Application, _
ByRef doc As Word.Document, _
ByVal message As String)
wd.Visible = False
If message <> "" Then
MsgBox message, vbCritical
End If
MsgBox " ＿＿＿＿＿＿＿＿_" & vbCrLf & _
" ／ ＼ " & vbCrLf & _
"／ ／・＼ ／・＼ ＼" & vbCrLf & _
"| ￣￣ ￣ | ち～んｗ" & vbCrLf & _
"| （＿人＿） |" & vbCrLf & _
"| ＼ | |" & vbCrLf & _
"＼ ＼＿| ／"
If Not doc Is Nothing Then
doc.Close False
End If
If Not wd Is Nothing Then
If wd.Documents.Count = 0 Then
wd.Quit
End If
End If
End Sub
コードの説明
- (1)。まずはStampedCopyMakerクラスのsetDocumentメソッドで元になるWordドキュメントをセット。
- (2)。(1)が失敗していたら、StampedCopyMakerクラスのisFailedプロパティがTrueになるので、その場合は(3)でshowFailureメソッドを実行。
- (4)。createCopyWithStampメソッドで、まずはWordドキュメントにハンコ画像を追加。
- (5)で、FolderCreatorクラスのcreateFolderを用いて保存用フォルダの有無を調べ、なかったら新たに作る。
- (6)。新たにフォルダを作った場合は、FolderCreatorクラスのobjFolder.fdIsCreatedプロパティがTrueになるので、新たにフォルダを作成した旨、メッセージを表示する。
- フォルダ作成の過程でエラーが発生していたらhasErrorプロパティがTrueになっているので、(8)でErrorCatcherクラスのshowErrorメソッドを用いてエラー発生についてユーザに知らせる。
- (9)では、DocPdfConverterクラスのconvertDocToPDFメソッドを用いてWordドキュメントをPDF化して保存。
- 以下、Wordドキュメントを保存せずに閉じて、Word.Applicationを終了している。
ざっとこんな感じ。
おわりに
他にも、リボンの表示／非表示を切り替えるコードとか、FileNameGetteクラスを使って、Wordドキュメントのフルパスとか、ハンコ用画像ファイルのフルパスを取得するコードなんかもあるけど、割愛。
あまり便利とかそういうのはないけど、こんなこともできますよ、ということで……。
クラスをクラスのフィールドにする
クラスをクラスのフィールドにする
クラスを丸ごとクラスのフィールドにしたらいいんじゃないか、と今さらながらに気がついた。Javaの本でさんざん目にしていたことなんだけど。
フィールド用のクラス
「GambleRacer」というクラスを作った。
クラスモジュールのコード
Option Explicit
'フィールド
Private name_ As String
Private racingStyle_ As String
Private racingPoints_ As Integer
'アクセサ
Public Property Get name() As String
name = name_
End Property
Public Property Get racingStyle() As String
racingStyle = racingStyle_
End Property
Public Property Get racingPoints() As Integer
racingPoints = racingPoints_
End Property
'コンストラクタ
'メソッド
Public Sub setData(ByVal n As String, _
ByVal rs As String, _
ByVal rp As Integer)
name_ = n
racingStyle_ = rs
racingPoints_ = rp
MsgBox "データをセットしました。"
End Sub
Public Sub showMyself()
MsgBox "私は" & name_ & "です。" & vbCrLf & _
"得意戦法は" & racingStyle_ & "、" & vbCrLf & _
"競走得点は" & racingPoints_ & "点です。"
End Sub
フィールドとして名前、戦法、競走得点の３つを持ち、メソッドとしてデータをセットするsetDataと、自己紹介をするshowMyselfの２つを持つクラス。
GambleRacerをフィールドに持つクラス
「KeirinRace」というクラスを作った。
クラスモジュールのコード
Option Explicit
'フィールド
Private gr_ As GambleRacer
'アクセサ
Public Property Get gr() As GambleRacer
Set gr = gr_
End Property
'コンストラクタ
'メソッド
Public Sub setData(ByRef gr As GambleRacer)
Set gr_ = gr
End Sub
Public Sub doKeirin()
With gr_
MsgBox .name & "の" & "渾身の" & .racingStyle & "が決まった！" & vbCrLf & _
"さすが" & .racingPoints & "点レーサー！"
End With
End Sub
フィールドとしてGambleRacerクラスを持ち、データをセットするsetDataと、競輪競走を行う（笑）doKeirinという２つのメソッドを持つクラスにした。
実行
標準モジュールに次のコードを書いて実行してみた。
標準モジュールのコード
Sub test() Dim kr As KeirinRace '……(1)' Set kr = New KeirinRace '……(2)' Dim gr As GambleRacer '……(3)' Set gr = New GambleRacer '……(4)' gr.setData "中野 浩一", "捲り", 120 '……(5)' gr.showMyself '……(6)' kr.setData gr '……(7)' kr.doKeirin '……(8)' Set gr = Nothing Set kr = Nothing End Sub
コードの説明
説明することに意義があるかどうかは不明なれど……。
- (1)でKeirinRaceクラスの変数を準備。
- (2)でKeirinRaceクラスのインスタンスを生成。
- (3)でGambleRacerクラスの変数を準備。
- (4)でGambleRacerクラスのインスタンスを生成。
- (5)で、GambleRacerクラスのsetDataメソッドを用いて各データをセット。こんなの、本来コンストラクタでやることですが。
- (6)で、GambleRacerクラスのshowMyselfメソッドを用いて自己紹介させる。
- (7)で、KeirinRaceクラスのsetDataメソッドを用いてデータをセット。引数としてGambleRacerクラスのインスタンスを渡している。
- (8)で、KeirinRaceクラスのdoKeirinメソッドを実行。
実行結果
GambleRacerクラスのsetDataメソッドが実行された証。
GambleRacerクラスのshowMyselfメソッドが実行された。
KeirinRaceクラスのdoKeirinメソッドも無事実行された。
おわりに
ちょっと今まで「クラスの独立性」という概念を勘違いしていたのかも。まだまだ勉強が足りませんな。
小さなクラスを作る(6)～WordドキュメントをPDFに変換する
WordドキュメントをPDFに変換して保存する
仕様
- Wordドキュメント
- そのWordドキュメントがあるフォルダパス
- ファイル名
以上３つをフィールドとして持つ。
メソッドは今のところ一つだけ。
- WordドキュメントをPDFにして指定のフォルダに保存する
- 元のWordドキュメントのあるフォルダにある保存用のフォルダに保存する
- 元のWordドキュメントのファイル名に任意の文字列を追加することができる
とまあ、こんな感じにした。
クラスモジュールのコード
オブジェクト名は「DocPDFConverter」とした。
フィールド部分
Option Explicit 'フィールド Private objDoc_ As Word.Document Private objPath_ As String Private objFileName_ As String
アクセサ部分
'アクセサ Public Property Get objDoc() As Word.Document Set objDoc = objDoc_ End Property Public Property Get objPath() As String objPath = objPath_ End Property Public Property Get objFileName() As String objFileName = objFileName_ End Property
メソッド部分
'メソッド
Public Sub convertDocToPDF(ByRef doc As Word.Document, _
ByVal tgtFolderName As String, _
Optional ByVal addStr As String = "") '……(1)'
Set objDoc_ = doc
objPath_ = doc.path
objFileName_ = doc.Name
Dim nameStr As String '……(2)'
nameStr = Left(objDoc_.Name, InStrRev(objDoc_.Name, ".") - 1) '……(3)'
objDoc_.ExportAsFixedFormat _
OutPutFileName:=objPath_ & "\" & tgtFolderName & "\" & addStr & nameStr & ".pdf", _
ExportFormat:=wdExportFormatPDF '……(4)'
DoEvents
End Sub
コードの説明
- (1)にあるように、引数は３つ。第１引数はWordドキュメントそのもの。第２引数は保存用のフォルダ名。第３引数は保存時にファイル名の先頭に加える文字列。Optionalなので省略可。
- (2)は、拡張子を除いたファイル名を入れるための変数。
- (3)で、拡張子を除いたファイル名を割り出す。
- (4)では、WordドキュメントオブジェクトのExportAsFixedFormatメソッドでPDFに変換・保存している。引数OutPutFileNameとExportFormatを指定して実行している。それぞれの引数が何を意味しているかは、コードを見たら分かると思う。
おわりに
なんだか、あんまりクラスにした意味が感じられないなあ。もっと柔軟な処理ができるようにした方がいいのかも。
まあ、でもこれで、写しPDF作成マクロに必要なものは出そろったので、ここらで写しPDF作成マクロシリーズに戻ることにしよう。
