見出し画像

一つのフォルダのなかのすべてのフォルダ名とフルパスを取得して配列にするには？

VBA_amateur_writer_hiro

手作業でフルパスを取得する

日々仕事でvbaを書いているhiroです。毎日お疲れ様です。
最近も新たなプロシージャをつくったのでご紹介します。標記のとおり、一つのフォルダのなかのすべてのフォルダ名とフルパスを取得するものです。普段は、as/r　というファイラー（windowsのエクスプローラーのようなもの）を使っており、このなかの「名前をクリップボードにコピー」という機能を使って、簡単にすべてのフォルダ名とフルパスを取得できます。正直、この機能があるから、as/r　を使っており、標準のエクスプローラーを使う気にはなれません。エクスプローラーも一つのファイルについてパスを取得する機能はありますが、すべてのパスを取得することはできないみたいですから。
エクスプローラーもwin11になってようやくタブ表示できるようになりましたが、as/r　は随分前からタブ表示でした。高機能すぎてよくわからないことの多いのが　as/r　です。

今回参考にしたページ

ですが、今回はあるプロシージャのなかの一つの機能として、あるフォルダの中のすべてのフルパスを取得する必要があり、何度も繰り返すので、毎回　as/r　で手作業でワークシートにコピペするわけにはいきません。探すと何かしらヒントになるページがヒットするのがvbaのいいところですね。今回はこのページ記載のプロシージャを参考にしました。

このプロシージャのポイントは再帰処理ですね。再帰処理とは、こちらによると「プログラミングにおいて、あるプロシージャの処理内部で再びそのプロシージャ自身を呼び出すような処理」だそうです。正直これまで使ったことがないのですが、これがないとすべての階層のファイルパスが取得できないことは何となくわかります。私のレベルでは何となくでいいや、と思っていますから深くは追及しません。

参考にしたページは取得した結果をワークシートに書き込みつつ、ファイルのフルパスではなくファイル名・サイズ・更新日時も取得してきれいな表に整形するものです。今回はファイル名とフルパスが欲しかったので、このページのプロシージャから再帰処理の部分を抽出して使いました。

最初のプロシージャ

まず一つ目のプロシージャです。
arr_file_fldr_name_list　と名付けました。


Function arr_file_fldr_name_list(ByVal fldrpath As String)
'arr_file_fldr_name_list:特定のフォルダの中のすべてのフォルダ名・ファイル名を取得する　 fldrpathの末尾は￥
'1列目：1＝フォルダ　２＝ファイル　２列目：階層レベル、１は直下　３列目：フォルダ名・ファイル名　４列目：フルパス

Dim objFSO As FileSystemObject

Dim rng As Range

Dim a As Long, b As Long, c As Long, d As Long, e As Long, f As Long, g As Long
Dim aa As Long, bb As Long, cc As Long, dd As Long, ee As Long, ff As Long, gg As Long
Dim h As Long, i As Long, j As Long, k As Long, l As Long, m As Long, n As Long
Dim hh As Long, ii As Long, jj As Long, kk As Long, ll As Long, mm As Long, nn As Long
Dim o As Long, p As Long, q As Long, r As Long, s As Long, t As Long, u As Long
Dim oo As Long, pp As Long, qq As Long, rr As Long, ss As Long, tt As Long, uu As Long
Dim v As Long, w As Long, x As Long, y As Long, z As Long
Dim vv As Long, ww As Long, xx As Long, yy As Long, zz As Long


Dim chk1st() As Long, chk2nd() As Long, chk3rd() As Long, chk4th() As Long, chk5th() As Long, chk6th() As Long, chk7th() As Long, chk8th() As Long, chk9th() As Long, chk10th() As Long, chk11th() As Long, chk12th() As Long, chk13th() As Long, chk14th() As Long, chk15th() As Long
Dim chkstr1st() As String, chkstr2nd() As String, chkstr3rd() As String, chkstr4th() As String, chkstr5th() As String, chkstr6th() As String, chkstr7th() As String, chkstr8th() As String, chkstr9th() As String, chkstr10th() As String, chkstr11th() As String, chkstr12th() As String, chkstr13th() As String, chkstr14th() As String, chkstr15th() As String
Dim txt1 As String, txt2 As String, txt3 As String, txt4 As String, txt5 As String, txt6 As String, txt7 As String, txt8 As String, txt9 As String, txt10 As String, txt11 As String, txt12 As String, txt13 As String, txt14 As String, txt15 As String

Dim daystr As String, timestr As String
daystr = Format(Date, "yymmdd")
timestr = Format(Time, "hhmmss")

Dim pt As String, fname As String, fpath As String

pt = Environ("HOMEDRIVE") & Environ("HOMEPATH") & "\Documents\"
fname = daystr & "-" & timestr & ".xlsx"
fpath = pt & fname

Dim wb As Workbook
Dim ws As Worksheet

Set wb = Workbooks.Add(xlWBATWorksheet)
wb.SaveAs Filename:=fpath, FileFormat:=xlWorkbookDefault
Set ws = Workbooks(fname).Worksheets(1)

'FileSystemObjectのインスタンスの生成
Set objFSO = New FileSystemObject
'フォルダの存在確認
If Not objFSO.FolderExists(fldrpath) Then
MsgBox ("指定のフォルダは存在しません")
Exit Function
End If


'開始行列
i = 1
j = 2
'再帰処理モジュールのコール
Call Module1001.GetDirFiles(objFSO.GetFolder(fldrpath), ws, i, j)
'オブジェクトの解放
Set objFSO = Nothing

ws.Activate
Set rng = ws.UsedRange
aa = rng(rng.count).row
bb = rng(rng.count).Column - 1
Set rng = Nothing

ReDim chk1st(1 To aa)
ReDim chk2nd(1 To aa)
ReDim chkstr1st(1 To aa)

For a = 1 To aa
'1:folder 2:file
chk1st(a) = Cells(a, 1).Value
For b = 1 To bb
If Cells(a, 1 + b).Value <> "" Then
txt1 = Cells(a, 1 + b).Value
xx = b
Exit For
End If
Next b
chkstr1st(a) = txt1
chk2nd(a) = xx
Next a

ReDim chkstr2nd(1 To aa, 1 To bb)
For a = 1 To aa
For b = 1 To bb
chkstr2nd(a, b) = Cells(a, 1 + b).Value
Next b
Next a


ReDim chkstr4th(1 To 1)
chkstr4th = Module1001.arr_file_fldr_name_list_part(chkstr2nd, chk2nd)


ReDim chkstr3rd(1 To aa, 1 To 4)
For a = 1 To aa
chkstr3rd(a, 1) = CStr(chk1st(a))
chkstr3rd(a, 2) = CStr(chk2nd(a))
chkstr3rd(a, 3) = chkstr1st(a)
chkstr3rd(a, 4) = fldrpath & chkstr4th(a)
Next a



wb.Close savechanges:=False

Kill fpath
Set ws = Nothing
Set wb = Nothing



arr_file_fldr_name_list = chkstr3rd

End Function

相変わらず、dimの部分で余計なことも書いていますが気にしないでください。毎回コピペでつけている部分ですので。
このプロシージャでダサいのは、毎回新しいブックをつくり、ワークシートにファイル名を階層的に書き込んで、それを読み取って配列にする、というところです。作成したブックはkillコマンドにより最終的に削除します。配列を可変に増やすこともできると思うのですが、まだそれがよくわかっていないことと、途中段階のチェックのためにこのようなかたちにしました。だからこのプロシージャを完成するためにブックを30ぐらい生成しました。ブックは、ドキュメントフォルダにつくります。

今回の核心である再帰処理プロシージャ

再帰処理の部分は、GetDirFiles　というプロシージャです。これは参考にしたページの核心部分です。


Sub GetDirFiles(ByVal objFolder As Folder, ByVal ws As Worksheet, ByRef i As Long, ByRef j As Long)
Dim objFolderSub As Folder
Dim objFile As File
Dim strSplit() As String


ws.Activate

'フォルダの取得
On Error Resume Next
For Each objFolderSub In objFolder.SubFolders
Cells(i, j).Value = objFolderSub.name
Cells(i, 1).Value = 1
i = i + 1
Call GetDirFiles(objFolderSub, ws, i, j + 1)
Next

'ファイルの取得
For Each objFile In objFolder.Files
With objFile
Cells(i, j).Value = .name
Cells(i, 1).Value = 2
i = i + 1
End With
Next


'オブジェクトの解放
Set objFolderSub = Nothing
Set objFile = Nothing
End Sub

普段は使わない　for each　を使っています。概念的なことは参考にしたページを参照してください。細かいことには拘らず使えるものは使う、という感じでつくりました。
ただ追加したのはフォルダの場合はワークシートの１列目に１、ファイルの場合は２を書き込むことにしたのです。これにより、ファイルとフォルダの区別をすることにしました。
階層的にセルに書き込むことは参考にしたページとまったく同じです。

フルパスをつくるプロシージャ

さて書き込んだ結果からフルパスをつくらないといけません。これが今回苦労したところです。それが以下の部分です。
arr_file_fldr_name_list_part　と名付けました。
GetDirFiles　でワークシートに書き込んだ結果を読み取り配列にしてから、それをフルパスに変換するまでです。byvalで代入するのは、フォルダ名・ファイル名の書き込み結果を配列にした　val、各フォルダ・ファイルがもとのフォルダから見て何階層にあるかを示す　arrlevel　という２つの配列です。


Function arr_file_fldr_name_list_part(ByVal val As Variant, ByVal arrlevel As Variant)
Dim a As Long, b As Long, c As Long, d As Long, e As Long, f As Long, g As Long
Dim aa As Long, bb As Long, cc As Long, dd As Long, ee As Long, ff As Long, gg As Long

Dim h As Long, i As Long, j As Long, k As Long, l As Long, m As Long, n As Long
Dim hh As Long, ii As Long, jj As Long, kk As Long, ll As Long, mm As Long, nn As Long

Dim o As Long, p As Long, q As Long, r As Long, s As Long, t As Long, u As Long
Dim oo As Long, pp As Long, qq As Long, rr As Long, ss As Long, tt As Long, uu As Long

Dim v As Long, w As Long, x As Long, y As Long, z As Long
Dim vv As Long, ww As Long, xx As Long, yy As Long, zz As Long


Dim val2nd() As Variant
Dim val3rd() As Variant
Dim chkstr1st() As String

cc = UBound(val, 1)
dd = UBound(val, 2)


ReDim val2nd(1 To cc, 1 To dd)

For d = 1 To dd
If d = 1 Then
    For c = 1 To cc
        If c = 1 Then
        val2nd(c, d) = val(c, d)
        Else
            If val(c, d) = "" Then
            val2nd(c, d) = val2nd(c - 1, d)
            Else
            val2nd(c, d) = val(c, d)
            End If
        End If
    Next c

Else

For c = 1 To cc
    If c = 1 Then
    val2nd(c, d) = val(c, d)
    Else
        If d <= arrlevel(c) Then
            If val(c, d - 1) = "" Then
                If val(c, d) = "" Then
                val2nd(c, d) = val2nd(c - 1, d)
                Else
                val2nd(c, d) = val(c, d)
                End If
            Else
            val2nd(c, d) = ""
            End If
        Else
        val2nd(c, d) = ""
        End If
    
    End If
Next c

End If
Next d

ReDim chkstr1st(1 To cc)

For c = 1 To cc
ReDim val3rd(1 To dd)
For d = 1 To dd
val3rd(d) = val2nd(c, d)
Next d
chkstr1st(c) = Application.WorksheetFunction.TextJoin("\", True, val3rd)
Next c

arr_file_fldr_name_list_part = chkstr1st


End Function

フルパスですからファイル名の前にフォルダ名がないといけません。そしてファイル名のあとに余計な情報が入ってはいけません。何度もやり直したのはこの部分です。

        If d <= arrlevel(c) Then
            If val(c, d - 1) = "" Then
                If val(c, d) = "" Then
                val2nd(c, d) = val2nd(c - 1, d)
                Else
                val2nd(c, d) = val(c, d)
                End If
            Else
            val2nd(c, d) = ""
            End If
        Else
        val2nd(c, d) = ""
        End If

ここで何階層目かを示す　arrlevel　の数値が効いています。ワークシート上で何度もどう作成されるかを確認しながらつくりました。最終的に書いた内容は上記のとおり短く、３つのIFが入れ子状態になっているだけですが、自分のつくりたい状態にたどり着くのは意外に時間がかかるものです。
最後は　textjoin関数　でフルパスの文字列をつくります。
これで最初の　arr_file_fldr_name_list　に戻ります。
作成する配列の情報は、1列目：1＝フォルダ　２＝ファイル　２列目：階層レベル、１は直下　３列目：フォルダ名・ファイル名　４列目：フルパス　という２次元配列で、２次元の要素数は４つです。もちろん１次元はすべてのフォルダ・ファイルの数なので、場合によっては万単位になります。
この配列を作成することでとりあえず必要なフルパスは得られました。

ファイル情報を取得するプロシージャ

ついでに特定のファイルのフルパスを代入したら、ファイル情報が得られるプロシージャも作成しました。get_file_info　と名付けました。

Function get_file_info(ByVal fpath As String)
'get_file_info: ファイル情報を取得し6要素の配列で返す
'１）ファイル名　２）ファイル作成日時　３）ファイル更新日時　４）ファイルサイズ(バイト)　５）ファイル種類　６）拡張子
'https://akira55.com/file_attributes/
'https://atmarkit.itmedia.co.jp/ait/articles/1704/19/news020.html
Dim File_function As New Scripting.FileSystemObject
Dim SetFile As Scripting.File

Set SetFile = File_function.GetFile(fpath)

Dim arr() As String
ReDim arr(1 To 6)
arr(1) = SetFile.name
arr(2) = SetFile.DateCreated
arr(3) = SetFile.DateLastModified
arr(4) = SetFile.Size
arr(5) = SetFile.Type
arr(6) = File_function.GetExtensionName(fpath)

Set SetFile = Nothing
Set File_function = Nothing
get_file_info = arr

End Function

参考にしたページはこちらの２つです。これは日時・サイズなどです。

こちらは拡張子の取得です。

どちらもおなじみの　FileSystemObject　を使うものですが、ちょうどPCを変えた時期だったので最初は動かず焦りました。参照設定の変更は忘れてしまいますね。Microsoft Scripting Runtime　にチェックを入れるという作業です。

終わりに

この一連のプロシージャをつくったのは、あるフォルダのなかから特定のテキストファイルのフルパスを取得し、テキストファイルの中身を読み取るためのものです。次は読み取りのためのプロシージャをご紹介したいと思います。
参考にしていただければ幸いです。

この記事が気に入ったらサポートをしてみませんか？