#VBA100本ノック 66本目

エクセルの神髄 の中の人がツイッターで行っている VBA100本ノック の66本目の解答記事です。

'Shell.Application を使った再帰ファイル探索処理及び、
'ADODB.Recordset を使ったセル出力のサンプル。
'ExcelのVBA上で実行し、出力先のワークシートを最前面にしていること。

'必要な参照設定。
'Imports Shell32 = Microsoft Shell Controls And Automation
'Imports ADODB   = Microsoft ActiveX Data Objects 6.1 Library

Public Sub VBA100Knock66()
'https://twitter.com/yamaoka_ss/status/1349222275820605442
'https://excel-ubara.com/vba100/VBA100_066.html
    
    Dim appShell As Shell32.Shell
    Set appShell = VBA.Interaction.CreateObject("Shell.Application")
    
    Dim rs As ADODB.Recordset
    Set rs = RecurseFileSeacrh( _
            appShell.Namespace(ThisWorkbook.Path), _
            ThisWorkbook.Name _
        )
    
    '自身を除外する。
    rs.Filter = "[Path] <> #" & ThisWorkbook.FullName & "#"
    If rs.RecordCount = 0 Then Exit Sub
    
    
    Dim ws As Excel.Worksheet
    Set ws = ActiveCell.Worksheet
    
    'Recordset のフィールド数と同じ列数のテーブルを作成。
    With ws.ListObjects.Add(xlSrcRange, ws.Cells.Resize(1, rs.Fields.Count), , xlYes)
        With .HeaderRowRange
            Dim recordFieldNames() As Variant
            recordFieldNames = NamesOfField(rs.Fields)
            
            'ヘッダーにフィールド名を設定。
            .Value() = recordFieldNames
            
            'データ範囲に Recordset の最初から以降全部の値を設定。
            .Offset(1).Resize(rs.RecordCount).Value() = _
                .Application.WorksheetFunction.Transpose( _
                    rs.GetRows( _
                        Rows:=ADODB.GetRowsOptionEnum.adGetRowsRest, _
                        Start:=ADODB.BookmarkEnum.adBookmarkFirst, _
                        Fields:=recordFieldNames _
                    ) _
                )
        End With '.HeaderRowRange
        
        '大きさ調整。
        With .Range
            .ColumnWidth = 100
            .Rows.AutoFit
            .Columns.AutoFit
        End With
    End With
End Sub

'汎用性は低い。
'inDirectory        :検索の起点となる Shell32.Folder3 オブジェクト。Shell32.Shell の Namespace メソッドなどで取得できる。
'inFileNamePattern  :探索したいファイル名のパターン。FolderItems3.Filter に渡されるので動作はよく確認すること。
'refRecordset       :省略可。結果を格納する ADODB.Recordset。既存の Recordset に結果を追記したい場合は設定する。
Private Function RecurseFileSeacrh( _
                 ByVal inDirectory As Shell32.Folder3, _
                 ByVal inFileNamePattern As String, _
        Optional ByRef refRecordset As ADODB.Recordset _
    ) As ADODB.Recordset
    
    '返り値の Recordset の用意。
    If refRecordset Is Nothing Then
        Set refRecordset = VBA.Interaction.CreateObject("ADODB.Recordset")
        With refRecordset.Fields
            .Append "Path", adBSTR
            .Append "ModifyDate", adDate
            .Append "Size", adInteger
        End With
        refRecordset.Open
    End If
    Set RecurseFileSeacrh = refRecordset
    
    
    'FolderItems3.Filterの1個目の引数に指定する定数。
        'https://docs.microsoft.com/en-us/windows/win32/api/shobjidl_core/ne-shobjidl_core-_shcontf
    Const SHCONTF_FOLDERS = &H20&       'フォルダのみを探す場合。
    Const SHCONTF_NONFOLDERS = &H40&    'ファイルのみを探す場合。
    
    'inDirectory 直下のファイル・フォルダ群の一覧を取得。
    Dim itms As Shell32.FolderItems3
    Set itms = inDirectory.Items()
    
    '名前が inFileNamePattern に一致するファイルのみにする。
        'ワイルドカードを考慮しなくていいのであれば`inDirectory.ParseName()`を使う手もある。
    itms.Filter SHCONTF_NONFOLDERS, inFileNamePattern
    
    '中の要素を列挙して Recordset に追加。
    Dim f As Shell32.FolderItem
    For Each f In itms
        Call refRecordset.AddNew( _
            VBA.[_HiddenModule].Array("Path", "ModifyDate", "Size"), _
            VBA.[_HiddenModule].Array(f.Path, f.ModifyDate, f.Size) _
        )
    Next f
    
    'フォルダーのみにフィルター。
    itms.Filter SHCONTF_FOLDERS, "*"
    
    '各フォルダーについて再帰。
    For Each f In itms
        Call RecurseFileSeacrh( _
                f.GetFolder, _
                inFileNamePattern, _
                refRecordset _
            )
    Next f
End Function


'Field の Name を格納した配列を作成する(簡易版)。
Private Function NamesOfField(ByVal inFields As ADODB.Fields) As Variant()
    Dim v() As Variant
    ReDim v(0 To inFields.Count - 1)
    
    Dim i As Long
    i = LBound(v)
    Dim f As ADODB.Field
    For Each f In inFields
        v(i) = f.Name
        i = i + 1
    Next f
    
    Let NamesOfField = v
End Function

その他関連ツイート