対象フォルダ内のファイルとフォルダ一覧を作成

Option Compare Database
Option Explicit

Dim modLngObjNumber As Long
Dim modFolderLevel As Integer

Sub prcStoreFilesInfoToTableA()
    Dim fso As FileSystemObject
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim strFolderPath As String
    Dim strSQL As String

    ' 探索するフォルダのパス
    strFolderPath = "C:\TargetFolder"
    
    '入力テーブル初期化
    DoCmd.SetWarnings False
    strSQL = "DELETE t.* FROM [t01a_test] AS t;"
    DoCmd.RunSQL strSQL
    DoCmd.SetWarnings True
    
    'Object準備
    Set fso = New FileSystemObject
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("t01a_test", dbOpenTable)
    
    ' フォルダ階層の初期化（最初のフォルダを階層0とする）
    modFolderLevel = 0
    
    'ファイル番号初期化
    modLngObjNumber = 1
    
    ' フォルダおよびサブフォルダ内のファイル情報を取得しテーブルに格納
    Call prcRecursiveFiles(fso.GetFolder(strFolderPath), fso, rst, modFolderLevel)

    ' オブジェクトを解放
    rst.Close
    Set rst = Nothing
    Set dbs = Nothing
    Set fso = Nothing
    
    'ステータスクリア
    SysCmd acSysCmdClearStatus
    
    MsgBox "処理終了"
End Sub

' 再帰的にファイル情報を取得するためのサブルーチン
Sub prcRecursiveFiles(folder As folder, fso As FileSystemObject, rst As DAO.Recordset, ByVal level As Integer)
    ' ステータスバー表示単位
    Const LNG_COUNTSTEP  As Long = 20
    'フォルダ関連
    Dim subFolder As folder
    Dim strFolderName As String
    Dim strFolderPath As String
    Dim strFolderSize As String
    Dim strFolderUpdDate As String
    'ファイル関連
    Dim file As file
    Dim strFileName As String
    Dim strExtension As String
    Dim strFilePath As String
    Dim strFileSize As String
    Dim strFileUpdDate As String
    'その他
    Dim strObjType As String
    Dim blnContinue As Boolean
    
    On Error GoTo ErrHdl

    ' フォルダ内の全てのファイルの情報を処理
    For Each file In folder.Files
        '初期化（エラーで値取得できないケースがあるため、いったん初期化）
        strFileName = ""
        strExtension = ""
        strFilePath = ""
        strFileSize = ""
        strFileUpdDate = ""
        strObjType = ""
        '値取得
        strFileName = file.Name
        strExtension = fncStrGetFileExtension(strFileName)
        strFilePath = file.Path
        strFileSize = Format(file.Size / 1024 / 1024, "#,##0") 'MBで取得
        strFileUpdDate = file.DateLastModified
        strObjType = "ファイル"
        
        With rst
            .AddNew
            !obj番号 = modLngObjNumber
            !フォルダ階層 = level
            !obj名 = strFileName
            !拡張子 = strExtension
            !objタイプ = strObjType
            !フルパス = strFilePath
            !objサイズ = strFileSize
            !更新日 = strFileUpdDate
            .Update
        End With
        
        '検出objカウントアップ
        modLngObjNumber = modLngObjNumber + 1
        
        '進捗表示
        If modLngObjNumber Mod LNG_COUNTSTEP = 0 Then
            Call prcStatusUpdate
        End If

        With rst
            .AddNew
            !obj番号 = modLngObjNumber
            !フォルダ階層 = level
            !obj名 = strFileName
            !拡張子 = strExtension
            !objタイプ = strObjType
            !フルパス = strFilePath
            !objサイズ = strFileSize
            !更新日 = strFileUpdDate
            .Update
        End With
        
    Next file

    ' サブフォルダを再帰的に処理
    For Each subFolder In folder.SubFolders
        '初期化（エラーで値取得できないケースがあるため、いったん初期化）
        strFolderName = ""
        strFolderPath = ""
        strFolderSize = ""
        strFolderUpdDate = ""
        strObjType = ""
        '値取得
        strFolderName = subFolder.Name
        strFolderPath = subFolder.Path
        strFolderUpdDate = subFolder.DateLastModified
        strObjType = "フォルダ"
        strFolderSize = Format(subFolder.Size / 1024 / 1024, "#,##0") 'MBで取得

        With rst
            .AddNew
            !obj番号 = modLngObjNumber
            !obj名 = strFolderName
            !フォルダ階層 = level
            !objタイプ = strObjType
            !フルパス = strFolderPath
            !更新日 = strFolderUpdDate
            !objサイズ = strFolderSize
            .Update
        End With
        
        '検出objカウントアップ
        modLngObjNumber = modLngObjNumber + 1
        
        '進捗表示
        If modLngObjNumber Mod LNG_COUNTSTEP = 0 Then
            Call prcStatusUpdate
        End If
        
        Call prcRecursiveFiles(subFolder, fso, rst, level - 1)
    Next subFolder
    
    Exit Sub
ErrHdl:
    Select Case Err.Number
        Case Else
            Debug.Print modLngObjNumber & ":" & Err.Number & "/" & Err.Description
            Stop
    End Select
End Sub

Function fncArrExcelWorksheetNames(strFilePath As String) As String()
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim strCon As String
    Dim arrSheetNames() As String
    Dim i As Integer

    ' 接続文字列をファイル形式に基づいて設定
    Select Case LCase(Right(strFilePath, Len(strFilePath) - InStrRev(strFilePath, ".")))
        Case "xls"
            ' Excel 97-2003 ファイル形式
            strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFilePath & ";Extended Properties=""Excel 8.0;HDR=NO;"""
        Case "xlsx", "xlsm"
            ' Excel 2007 以降のファイル形式
            strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFilePath & ";Extended Properties=""Excel 12.0 Xml;HDR=NO;"""
    End Select

    ' ADO接続オブジェクトを作成
    Set cn = New ADODB.Connection
    cn.Open strCon

    ' ワークシート名を取得
    Set rs = cn.OpenSchema(adSchemaTables)
    i = 0
    Do While Not rs.EOF
        ReDim Preserve arrSheetNames(i)
        arrSheetNames(i) = Replace(rs.Fields("TABLE_NAME").Value, "$", "")
        i = i + 1
        rs.MoveNext
    Loop
    rs.Close

    ' オブジェクトを閉じて解放
    Set rs = Nothing
    cn.Close
    Set cn = Nothing

    fncArrExcelWorksheetNames = arrSheetNames
End Function
' ----------------------------------------------------------------
' 機能概要:ステータスバー更新
' ----------------------------------------------------------------
Sub prcStatusUpdate()
    Dim strText As String
    
    strText = "オブジェクト取得中・・・ " & modLngObjNumber & " obj"
    SysCmd acSysCmdSetStatus, strText
    DoEvents
End Sub
' ----------------------------------------------------------------
' 機能概要: 拡張子がついたファイル名から拡張子の部分を返す
' 引数:strFileName - ファイル名（拡張子含む）
' 戻り値:String - ファイルの拡張子
' ----------------------------------------------------------------
Function fncStrGetFileExtension(strFileName As String) As String
    Dim intDotPosition As Integer
    Dim strExtension As String

    ' ファイル名から最後のドットの位置を見つける
    intDotPosition = InStrRev(strFileName, ".")

    ' ドットが見つかった場合、拡張子を抽出
    If intDotPosition > 0 Then
        strExtension = Mid(strFileName, intDotPosition + 1)
        fncStrGetFileExtension = strExtension
    End If
End Function
' ----------------------------------------------------------------
' 機能概要: 書き込み可能フォルダか判定する
' 引数:strFolderPath - 判定するフォルダパス
' 戻り値:Boolean - True=書き込み可 ,False=書き込み不可
' ----------------------------------------------------------------
Function fncBlnFolderWritable(fso As FileSystemObject, strFolderPath As String) As Boolean
    ' 変数の宣言
    Dim strTempFilePath As String
    Dim fileTest As TextStream

    ' 一時ファイルのパスを設定
    strTempFilePath = strFolderPath & "\tempfile.tmp"

    On Error Resume Next ' エラーハンドリングを開始

    ' 一時ファイルの作成を試みる
    Set fileTest = fso.CreateTextFile(strTempFilePath, True)

    ' エラーチェック
    If Err.Number = 0 Then
        fileTest.Close ' テストファイルを閉じる
        fso.DeleteFile strTempFilePath ' テストファイルを削除
        fncBlnFolderWritable = True
    Else
        fncBlnFolderWritable = False
    End If
    On Error GoTo 0 ' エラーハンドリングを終了

End Function