再帰呼び出しを使用したファイルのリストアップ

ファイルのリストアップ

 プログラムのある関数が、自分自身の関数を呼び出す「再帰」。その再帰呼び出しを利用して、任意のフォルダのサブフォルダ、ファイルをリストアップするコードとメモです。

ポイント

 ・FileDiarogプロパティ
 ・フォルダの存在確認
 ・再帰呼び出し
 ・FileSystemObject

 FileDialogプロパティの引数に「msoFileDialogFolderPicker」を設定しコードを実行すると、「参照」のダイアログが表示される。ダイアログではフォルダを選択でき、選択したフォルダは、SelectedItemsプロパティで、そのパスを取得できる。

 何らかの理由で、フォルダの存在を確認するケースも考えられるので、Dir関数を用いたフォルダの存在確認方法を、補足として併記する。

 再帰呼び出しは、ある計算結果に対して同じ処理を連続して行う場合に使うことが多い。コードが簡素化される利点もあるが、処理から抜ける条件が成り立たず、無限ループに陥ることがあるため、気をつけなければならない。
 今回、再帰呼び出しのサンプルとしてファイルをリストアップする。尚、処理を抜ける条件は「任意のフォルダにサブフォルダが存在しない」である。

 再帰呼び出し中での、フォルダ、ファイルの操作にはFileSystemObjectを使用した。

 このコードを利用したソフトはこちら「ファイルリストアップ
 処理の中断、重複ファイルの確認等の処理を追加している。


サンプルコード

再帰呼び出しを利用したファイルのリストアップ。リストアップしたデータは新規ブックに書き込まれる。

Option Explicit

Private lngUsedRow As Long, lngUsedCol As Long 'データ書込に使用するセル範囲カウント用
Private lngDireCount As Long, lngFileCount As Long 'フォルダ、ファイル数格納用
Private strDP As String, strSep As String
Private varArea As Variant
Private strDirName(1 To 3) As String
'-------------------------------------------------------------------------------------------------------

Sub Main_Sub()
    With Application.FileDialog(msoFileDialogFolderPicker)
        strDP = ""
        If .Show = True Then strDP = .SelectedItems(1) 'フォルダ選択
        If strDP = "" Then Exit Sub
    End With
        
    If File_ListUp Then 'サーチ
        MsgBox "フォルダ数:" & lngDireCount & vbCrLf & _
               "ファイル数:" & lngFileCount, _
               vbOKOnly + vbInformation, "処理完了"
    End If
    strDP = Dir("")
End Sub
'-------------------------------------------------------------------------------------------------------

Private Function File_ListUp() As Boolean
    Dim lngSep As Long, lngSC As Long
    Dim strDN As String 'フォルダ名格納用
    
    With Application
        strSep = .PathSeparator 'パスセパレーターの取得
        lngSep = InStrRev(strDP, strSep)
        If lngSep = 0 Then GoSub FIN_1
        If strSep = Right$(strDP, 1) Then strDP = Left$(strDP, Len(strDP) - 1)
        On Error GoTo FIN_1
            strDN = Dir(strDP, vbDirectory) 'フォルダの存在確認
        On Error GoTo 0
        If strDN = "" Then GoSub FIN_1
        If InStr(strDP, strSep) = 0 Then strDN = ""
        
        lngDireCount = 1
        lngFileCount = 0
        Call Count_Dir_File(1, 2, Left$(strDP, lngSep), strDN & strSep)
        
        lngSC = .SheetsInNewWorkbook
        .SheetsInNewWorkbook = 1 'シート数を1枚に設定
        .Workbooks.Add '新しいブックの挿入
        .SheetsInNewWorkbook = lngSC
        With .ActiveWorkbook.Worksheets(1)
            If .Rows.Count < lngUsedRow Or .Columns.Count < lngUsedCol Then GoSub FIN_2
            If lngUsedRow = 0 Then lngUsedRow = 1
            If lngUsedCol < 2 Then lngUsedCol = 2
            With .Range(.Cells(1, 1), .Cells(lngUsedRow, lngUsedCol))
                varArea = .Value
                strDirName(1) = "["
                strDirName(3) = "]"
                If strDN = "" Then strDirName(2) = strDP Else strDirName(2) = strDN
                varArea(1, 1) = Join$(strDirName)
                Call ListUp_Main(2, 2, Left$(strDP, lngSep), strDN & strSep)
                .Value = varArea '書き込み
            End With
            .UsedRange.EntireColumn.ColumnWidth = 4.38
            Erase varArea
        End With
    End With
    File_ListUp = True
Exit Function
FIN_1:
    MsgBox "選択したフォルダは対象外です", vbOKOnly + vbExclamation, "中止します"
Exit Function
FIN_2:
    MsgBox "シートに表示しきれません", vbOKOnly + vbExclamation, "中止します"
End Function
'-------------------------------------------------------------------------------------------------------

'フォルダ、ファイル数のカウント用プロシージャ(再帰
Private Sub Count_Dir_File(ByRef r As Long, ByRef c As Long, _
                            ByVal strDirPath As String, ByVal strNewDir As String)
    Dim F As Object, FSO As Object, objDirectory As Object
    On Error GoTo ERR
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set objDirectory = FSO.GetFolder(strDirPath & strNewDir)
        With objDirectory
            lngDireCount = lngDireCount + .SubFolders.Count
            If 0 < .SubFolders.Count Then 'サブフォルダの有無確認
                For Each F In .SubFolders
                    c = c + 1
                    r = r + 1
                    If lngUsedCol < c Then lngUsedCol = c
                    Call Count_Dir_File(r, c, strDirPath & strNewDir, F.Name & strSep)
                    c = c - 1
                Next
            End If
            lngFileCount = lngFileCount + .Files.Count 'ファイル数取得
            r = r + .Files.Count
            lngUsedRow = r
        End With
    On Error GoTo 0
ERR:
    Set objDirectory = Nothing
    Set FSO = Nothing
End Sub
'-------------------------------------------------------------------------------------------------------

'フォルダ、ファイル名を変数に格納するプロシージャ(再帰
Private Sub ListUp_Main(ByRef r As Long, ByRef c As Long, _
                        ByVal strDirPath As String, ByVal strNewDir As String)
    Dim F As Object, FSO As Object, objDirectory As Object
    On Error GoTo ERR
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set objDirectory = FSO.GetFolder(strDirPath & strNewDir)
        With objDirectory
            If 0 < .SubFolders.Count Then
                For Each F In .SubFolders
                    strDirName(2) = F.Name 'フォルダ名取得
                    varArea(r, c) = Join$(strDirName)
                    c = c + 1
                    r = r + 1
                    Call ListUp_Main(r, c, strDirPath & strNewDir, F.Name & strSep)
                    c = c - 1
                Next
            End If
            If 0 < .Files.Count Then
                For Each F In .Files
                    varArea(r, c) = F.Name 'ファイル名の取得と代入
                    r = r + 1
                Next
            End If
        End With
    On Error GoTo 0
ERR:
    Set objDirectory = Nothing
    Set FSO = Nothing
End Sub

※サンプルコードがエラーで中断される場合
 ・VBEのオプション設定を変更 参照
 ・プロジェクトをロックする 参照

メモ

◆再帰呼び出しサブルーチンListUp_Mainプロシージャの流れ
 [ 1 ] FileSystemObjectのインスタンスを作成
 [ 2 ] 与えられたパスのフォルダオブジェクトを作成
 [ 3 ] 該当フォルダオブジェクトのサブフォルダ数を確認
      サブフォルダ在り:サブフォルダのパスを自身(ListUp_Mainプロシージャ)に設定し[ 1 ]へ
      サブフォルダなし:[ 4 ]へ
 [ 4 ] 該当フォルダオブジェクトのファイル数を確認
      ファイル在り:ファイル名を取得後[ 5 ]へ
      ファイルなし:[ 5 ]へ
 [ 5 ] フォルダオブジェクト、FileSystemObjectのインスタンスを破棄
 [ 6 ] この階層のListUp_Mainプロシージャを抜ける

◆「$」の付く関数
 参照

◆Join関数
 参照

◆InstrRev関数
 参照

◆FileDiarogプロパティ
 ファイルダイアログを表示する。引数により表示されるダイアログの種類が異なる。引数に設定できるのは、次のMsoFileDialogTypeクラスの定数のいずれか。

  ・msoFileDialogFilePicker 「参照」ダイアログでファイルを選択できます。
  ・msoFileDialogFolderPicker 「参照」ダイアログでフォルダを選択できます。
  ・msoFileDialogOpen 「ファイルを開く」ダイアログ
  ・msoFileDialogSaveAs 「名前をつけて保存」ダイアログ

 ファイルダイアログは、ファイル(フォルダ)のパスを取得するものであり、「ファイルを開く」や「名前をつけて保存」のダイアログであっても、実際にファイルが開かれたり、保存されるものではない。

 ダイアログで選択したファイル(フォルダ)パスの取得には、SelectedItemsプロパティを使用する。使用例は以下を参照。

Sub UseFileDialogOpen()
    Dim lngCount As Long
    ' ファイル ダイアログを開きます。
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = True 'ファイルの複数選択を可能にする
        .Show
        ' 選択された各ファイルのパスを表示します。
        For lngCount = 1 To .SelectedItems.Count
            MsgBox .SelectedItems(lngCount)
        Next lngCount
    End With
End Sub

◆Dir関数
 指定したパターンやファイル属性に一致する、ファイルやフォルダの名前の文字列を返す。返される文字列は(String型)。ドライブのボリュームラベルも取得可能。

 構文:Dir[(pathname[, attributes])]

 [pathname]
  ファイル名を表す文字列式を指定。フォルダ名やドライブ名も含めて指定可能。
  指定した内容が見つからないときは、長さ「0」の文字列を返す。

 [attributes]
  省略可能です。取得したいファイルの属性の値の合計、または定数を指定。
  省略すると、標準ファイルの属性。Windowsでの「設定値」は以下の6つ
   【定数 / 値 / 内容】
   vbNormal / 0 / 標準ファイル
   vbReadOnly / 1 / 読み取り専用ファイル
   vbHidden / 2 / 隠しファイル
   vbSystem / 4 / システム ファイル
   vbVolume / 8 / ボリューム ラベル。この値を指定すると、すべての属性は無効。
   vbDirectory / 16 / フォルダ

◆FileSystemObject
 後日記載。

Excel Tips for Teachers

Copyright (C) 2009- 坂江 保 All Rights Reserved.