再帰処理に初挑戦

前回

akashi-keirin.hatenablog.com

の続き。

Foobar2000用の音楽フォルダ管理の話。

とりあえず、フォルダの中身はコピーせずに、フォルダ構成だけを別フォルダにコピーしたい。

任意のフォルダ内の子フォルダだけを別のフォルダにコピーするマクロ

FileSystemObjectのSubFoldersコレクションとCreateFolderメソッドを使えば楽勝。

リスト１　標準モジュール

'### Microsoft Scripting Runtime参照設定 ###'
Option Explicit

Private fsObj As FileSystemObject

Public sub copyFolderStructure( _
             ByVal srcDir As String, _
             ByVal destDir As String)  '……(1)'
  If fsObj Is Nothing Then _
    Set fsObj = New FileSystemObject  '……(2)'
  Dim tgtFolder As Folder    '……(3)'
  Set tgtFolder = fsObj.GetFolder(srcDir)
  Dim subFolder As Folder    '……(4)'
  For Each subFolder In tgtFolder.SubFolders
    fsObj.CreateFolder(destDir & "\" & subFolder.Name)    '"
  Next
End Function

(1)の

Public sub copyFolderStructure( _
             ByVal srcDir As String, _
             ByVal destDir As String)

で引数設定。

第１引数srcDirでコピー元のフォルダパスを受け取り、第２引数destDirでコピー先のフォルダパスを受け取る。

(2)の

If fsObj Is Nothing Then _ Set fsObj = New FileSystemObject

でFileSystemObjectのインスタンスを生成。

変数fsObjはモジュールレベル変数なので、インスタンス化していないときだけSetする。

(3)の

Dim tgtFolder As Folder
Set tgtFolder = fsObj.GetFolder(srcDir)

では、FileSystemObjectオブジェクトのGetFolderメソッドを用いて、コピー元のフォルダをFolderオブジェクトとして取得。変数tgtFolderにぶち込んでいる。

そして、(4)の

Dim subFolder As Folder
For Each subFolder In tgtFolder.SubFolders
  Call fsObj.CreateFolder(destDir & "\" & subFolder.Name)    '"
Next

では、tgtFolderオブジェクトのSubFoldersコレクションから子フォルダを一つづつ取り出してsubFolderにぶち込み、そのNameプロパティを利用してコピー先のフォルダパスを作成。そうしてできたフォルダパスをCreateFolderメソッドに渡してコピー先に新しいフォルダを作成する。

めちゃくちゃ簡単である。

リスト１の問題点

しかし、リスト１のやり方には問題点がある。

子フォルダの中にある孫フォルダ、曾孫フォルダ、……まではコピーできないのだ。

そこでどうするか。リスト１の(4)のところで、取り出した子フォルダ（subFolderにぶち込まれたフォルダ）にさらに孫フォルダがあるときには、子フォルダをcopyFolderStructureに渡すようにすればいいのである。

copyFolderStructure内からcopyFolderStructureメソッドを呼ぶ

リスト１を次のように書き換える。

リスト２　標準モジュール

Public sub copyFolderStructure( _
             ByVal srcDir As String, _
             ByVal destDir As String)
  If fsObj Is Nothing Then _
    Set fsObj = New FileSystemObject
  Dim tgtFolder As Folder
  Set tgtFolder = fsObj.GetFolder(srcDir)
  Dim subFolder As Folder    '……(5)'
  For Each subFolder In tgtFolder.SubFolders
    Dim newFolder As Folder
    Set newFolder = fsObj.CreateFolder( _
                            destDir & "\" & subFolder.Name)        '"
    If subFolder.SubFolders.Count > 0 Then _
      call copyFolderStructure( _
                            subFolder.Path, newFolder.Path)
  Next
End Sub

変えたのは(5)のForループのところ。

コピー先に新たに作ったフォルダを変数newFolderにぶち込むようにしている。

そして、subFolderにぶち込まれているフォルダについて、SubFoldersプロパティの値を調べ、0よりも大きいとき、すなわちさらに孫フォルダがあるときには、subFolder自身のフルパスと、先ほど作ったコピー先のnewFolderのフルパスをcopyFolderStructureに渡す。

これで、中にフォルダがある限り掘り進めて行ってくれる。

使ってみる

今回のマクロを書いたブックのあるフォルダ内に次のようなフォルダ群を準備。

f:id:akashi_keirin:20190914105737j:plain

Test1とTest2というフォルダが同じ階層にあり、そのうちTest1フォルダの方には、ご覧のように子、孫フォルダが入っている。

f:id:akashi_keirin:20190914105741j:plain

ちなみに、当然Test2フォルダの中は空っぽ。

この状態で、次のコードを実行する。

リスト３　標準モジュール

Private Sub testCopyFolderStructure()
  Dim srcDir As String
  srcDir = ThisWorkbook.Path & "\Test1"
  Dim destDir As String
  destDir = ThisWorkbook.Path & "\Test2"
  Call copyFolderStructure(srcDir, destDir)
End Sub

copyFolderStructureメソッドにTest1フォルダのパスとTest2フォルダのパスを渡しているだけ。

こいつを実行すると、Test2フォルダの中は

f:id:akashi_keirin:20190914105746g:plain