指定ディレクトリ内のフォルダ名を表示（その３）

bhunji20002009-10-29

サブフォルダの再帰処理

（その１）、（その２）ではサブフォルダの取得はおこなってましたが、サブフォルダのサブフォルダの取得はできません。

folder\folder1\folder11←「folder1」取得、「folder11」は取得しない
folder\folder1\folder12←「folder12」は取得しない
folder\folder2\folder21←「folder2」取得、「folder21」は取得しない
folder\folder3\folder31←「folder3」取得、「folder31」は取得しない

そこで、次のようにします。
1「folder」のサブフォルダである「folder1」を取得
2「folder1」のサブフォルダである「folder11」を取得
3「folder11」のサブフォルダである「folder111」を取得

サブフォルダが見つけられなくなったら、一つ上のフォルダに戻り
別のサブフォルダに対して同様の処理を行うようにします。

実装としては
1の結果を2の引数として渡します。
2の結果を3の引数として渡します。

例えば、4に渡す引数が存在しない場合、3は終了し、
同様に順次2、1と終了していきます。

これを自分のメソッドの中でさらに自分のメソッドを呼び出す処理にします。

※showSubFolder1()を実行するとすべてのサブフォルダを表示し、フォルダごとに線を引きます。
(内包するフォルダ数が多いと処理できなくなりかたまってしまいます。次回対処します。)

＜Excel VBA 指定ディレクトリ内のフォルダ名を表示（その３）＞

Option Explicit

Sub showSubFolder1()

    'A1セルの文字列を取得

    Dim dPath As String

    dPath = Cells(1, "A")

    '文字列が空白だったら終了

    If dPath = "" Then

        MsgBox "A1セルが空白です。"

        Exit Sub

    '文字列の末尾が「\」じゃなかったら付加する

    ElseIf Right(dPath, 1) <> "\" Then

        dPath = dPath & "\"

    End If

    'ディレクトリが存在しない又はフォルダが存在しない

    If Dir(dPath, vbDirectory) = "" Then

        MsgBox "ディレクトリが存在しない又はフォルダが存在しません。"

        Exit Sub

    End If

    'オブジェクトの生成

    Dim objFS As FileSystemObject

    Set objFS = CreateObject("Scripting.FileSystemObject")

    'サブフォルダ分ループ

    Dim Folder As Folder

    Dim y As Integer

    Dim x As Integer

    Dim xMax As Integer

    y = 2

    x = 2

    xMax = 2    '←使用する最大列

    On Error GoTo err

    For Each Folder In objFS.GetFolder(dPath).SubFolders

        'B列にフォルダ名を表示

        Cells(y, x).Value = Folder.Name

        Call showSubFolder2(Folder, y, x, xMax)   '←メソッド呼び出し

        y = y + 1

    Next

    On Error GoTo 0

    'オブジェクトの解放

    Set objFS = Nothing

    '線を引く

    Dim yMax

    yMax = y - 1    '使用した最大行

    Call showLine(yMax, xMax)   '←メソッド呼び出し

    Exit Sub



err:

    MsgBox "エラーです。"

    'オブジェクトの解放

    Set objFS = Nothing

    Exit Sub

End Sub

Sub showSubFolder2(ByRef objFol As Folder, ByRef y As Integer, ByRef x As Integer, ByRef xMax As Integer)

    'サブフォルダが存在する場合

    If objFol.SubFolders.Count <> 0 Then

        x = x + 1   '←サブフォルダを表示させるため、1列右へ

        '使用する最大列更新

        If xMax < x Then

            xMax = x

        End If

        'サブフォルダ分ループ

        Dim Folder As Folder

        For Each Folder In objFol.SubFolders

            y = y + 1   '←表示させる前に下の行へ

            Cells(y, x).Value = Folder.Name

            Call showSubFolder2(Folder, y, x, xMax)   '←自メソッドを再帰的に呼び出す

        Next

        x = x - 1   '←表示が終わったら、親フォルダの列に戻る

    End If

End Sub

Sub showLine(ByVal yMax As Integer, xMax As Integer)



    Dim y As Integer

    Dim x As Integer



    'フォルダごとに区切り線を入れる

    For y = 1 To yMax

        For x = 1 To xMax

            If Cells(y, x) <> "" Then

                '「何か入っているセル」から「最大行・最大列のセルまでを選択する。」

                Range(Cells(y, x), Cells(yMax, xMax)).Select

                '↓選択セルを線で囲む処理(中の線は消す)をマクロ記録しました。

                '----------------ここから----------------

                Selection.Borders(xlDiagonalDown).LineStyle = xlNone

                Selection.Borders(xlDiagonalUp).LineStyle = xlNone

                With Selection.Borders(xlEdgeLeft)

                    .LineStyle = xlContinuous

                    .Weight = xlThin

                    .ColorIndex = xlAutomatic

                End With

                With Selection.Borders(xlEdgeTop)

                    .LineStyle = xlContinuous

                    .Weight = xlThin

                    .ColorIndex = xlAutomatic

                End With

                With Selection.Borders(xlEdgeBottom)

                    .LineStyle = xlContinuous

                    .Weight = xlThin

                    .ColorIndex = xlAutomatic

                End With

                With Selection.Borders(xlEdgeRight)

                    .LineStyle = xlContinuous

                    .Weight = xlThin

                    .ColorIndex = xlAutomatic

                End With

                Selection.Borders(xlInsideVertical).LineStyle = xlNone

                Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

                '----------------ここまで----------------

            End If

        Next x

    Next y

End Sub