サブフォルダも含め配下のフォルダパス全てを返すFunction

作ってみた

いや、FileSystemObject使えよ、って話なんですけどね。

Dir関数使って作ったらどうなんのかな、と思って。

ソースコードを晒す

場当たり的に作ったやつなので、だいぶ恥ずかしいのですが、晒します。

リスト１

Public Function GetFolderPathAll( _
            ByVal a_FolderPath As String) As String
'配下の全てのフォルダのパスを、「&gt」で区切った文字列にして返す｡ '
  Dim ret As String
  ret = ""
  '対象のフォルダがなかったらReturn'
  If Dir(a_FolderPath, vbDirectory) = "" Then GoTo ReturnValues
  Dim tmp As String
  tmp = Dir(a_FolderPath & "\*", vbDirectory)
  Do
    'Dirが文字列を返さなかったらループを抜ける。'
    If tmp = "" Then Exit Do
    'Dirの返り値が「.」、「..」だったらContinue'
    If tmp = "." Then GoTo Continue
    If tmp = ".." Then GoTo Continue
    tmp = a_FolderPath & "\" & tmp                  '"
    'フォルダパスじゃなかったらContinue'
    If GetAttr(tmp) <> vbDirectory Then GoTo Continue
    'ここまでたどり着いたらフォルダパスのはず。'
    'あとでSplitするときのために、区切り文字をファイルパスに'
    '使えない文字にする'
    ret = ret & tmp & ">"
Continue:
    tmp = Dir()
  Loop
  Dim arr() As String
  arr = Split(ret, ">")
  Dim i As Long
  'この段階では右端に「>」があるので、配列の最後の要素は空。'
  For i = LBound(arr) To UBound(arr) - 1
    'GetFolderPathAllメソッドに投げるときには右端が「>」で'
    'でないといけない。'
    If Right(ret, 1) <> ">" Then
    '一番底のフォルダまで行ったときは、右端に「>」が付いてい'
    'ない文字列が「arr()」に入っている。'
      ret = ret & ">"
    End If
    'サブフォルダを調べる。（再帰呼び出し）'
    ret = ret & GetFolderPathAll(arr(i))
  Next
ReturnValues:
  If ret <> "" Then
    If Right(ret, 1) = ">" Then
    '最後は右端の「>」をトル。'
      ret = Left(ret, Len(ret) - 1)
    End If
  End If
  GetFolderPathAll = ret
End Function

ルートのフォルダのフルパスを渡して実行すると、配下のフォルダ全てのフルパスを「>」で区切って一列棒状にした長～い文字列を返す、というもの。

地味に再帰を使っています。

使ってみる

とりあえずフォルダの準備

こんなフォルダ構成を、マクロを書いたDocumentのあるフォルダに作りました。

WordでVBAを書いているところにはツッコミなしで！

こんなコードで実行

次のコードを実行します。

リスト２

Private Sub test03()
  Dim tgtDir As String
  tgtDir = ThisDocument.Path
  Dim arr() As String
  arr = Split(GetFolderPathAll(tgtDir), ">")
  Dim i As Long
  For i = LBound(arr) To UBound(arr)
    Debug.Print arr(i)
  Next
End Sub

GetFolderPathAllメソッドの返り値は、配下の各フォルダパスが「>」によって数珠つなぎにされた長～い文字列なので、Splitで区切って配列化し、それを一つづつ取り出してイミディエイトに書き出します。