【Access VBA】FileSystemObjectから取得できる情報をテーブルに書き込むサンプル

この記事では、Access VBAで FileSystemObject (FSO) を使用し、指定したフォルダ内のフォルダ情報やファイル情報を取得して、自動的にテーブルへ書き込むサンプルコードを紹介します。

再帰処理を用いてサブフォルダ内もくまなく走査するため、ファイル管理やバックアップ状況の調査などに活用できます。

前提条件・動作環境

• Microsoft Access 2010以降（VBA環境）
• 参照設定で「Microsoft Scripting Runtime」を有効にしていること

出力先テーブルの準備

あらかじめ「テーブル1」という名前のテーブルを作成し、以下のフィールド（列）を用意してください。

• 処理結果 (短テキスト / テキスト)
• Attributes (数値)
• DateCreated (日付/時刻)
• DateLastAccessed (日付/時刻)
• DateLastModified (日付/時刻)
• Drive (短テキスト)
• IsRootFolder (短テキスト)
• Name (短テキスト)
• ParentFolder (短テキスト)
• Path (短テキスト)
• ShortName (短テキスト)
• ShortPath (短テキスト)
• Size (数値 または 長整数)
• Type (短テキスト)
• エラー情報 (短テキスト / メモ) ※エラー発生時用

サンプルコード

標準モジュールに以下のコードを貼り付けて実行します。

Option Compare Database
Option Explicit

Private g_cntFILE As Long
Private g_cntPATH As Long
Private DB As DAO.Database ' 出力先DB
Private RS As DAO.Recordset ' 出力先RecordSet

'*******************************************************************************
'   全体処理(ルートフォルダを指定して探索を開始)
'*******************************************************************************
Sub SEARCH_FOLDER()
    Dim objFSO As FileSystemObject
    Dim strPATHNAME As String
    
    ' テーブルを開く
    Set DB = CurrentDb()
    DB.Execute ("DELETE FROM テーブル1")
    
    Set RS = DB.OpenRecordset("テーブル1", dbOpenTable)
    
    strPATHNAME = InputBox("フォルダ指定", "フォルダ指定", "C:\Program Files")
    If strPATHNAME = "" Then Exit Sub
    
    Set objFSO = New FileSystemObject
    ' ルートフォルダから探索開始
    Call SEARCH_SUB_FOLDER(objFSO.GetFolder(strPATHNAME), 0, 0)
    
    ' テーブルを閉じる
    RS.Close
    Set RS = Nothing
    
    ' 参照OBJECTを破棄
    Set objFSO = Nothing
    
    MsgBox "処理が完了しました。" & vbCr & vbCr & _
        "フォルダ数=" & g_cntPATH & vbCr & _
        "ファイル数=" & g_cntFILE, vbInformation
End Sub

'*******************************************************************************
'   フォルダ単位のサブ処理(再帰動作)
'*******************************************************************************
Private Sub SEARCH_SUB_FOLDER(ByVal objPATH As Folder, ByRef GYO As Long, ByVal COL As Long)
    Dim objPATH2 As Folder
    Dim objFILE As File
    On Error GoTo EXCEPTION

    g_cntPATH = g_cntPATH + 1

    For Each objPATH2 In objPATH.SubFolders
        ' レコード出力（フォルダ分）
        Call WriteFolderInfo(RS, objPATH2)
        ' フォルダ単位のサブ処理(再帰呼び出し)
        Call SEARCH_SUB_FOLDER(objPATH2, GYO, COL)
    Next objPATH2

    ' 本フォルダの各ファイルを処理するループ
    For Each objFILE In objPATH.Files
        g_cntFILE = g_cntFILE + 1
        Call WriteFileInfo(RS, objFILE)
        
        ' 処理が長い場合に備えて画面を更新
        RS.Requery
        DoEvents
    Next objFILE
    
    Set objPATH = Nothing
    Exit Sub

EXCEPTION:
    Resume Next
End Sub

Sub WriteFolderInfo(ByRef RS As Recordset, ByRef objPATH As Folder)
    On Error GoTo EXCEPTION
        RS.AddNew
        RS.Fields("処理結果") = "OK"
        RS.Fields("Attributes") = objPATH.Attributes
        RS.Fields("DateCreated") = objPATH.DateCreated
        RS.Fields("DateLastAccessed") = objPATH.DateLastAccessed
        RS.Fields("DateLastModified") = objPATH.DateLastModified
        RS.Fields("Drive") = objPATH.Drive
        RS.Fields("IsRootFolder") = ToBooleanString(objPATH.IsRootFolder)
        RS.Fields("Name") = objPATH.Name
        RS.Fields("ParentFolder") = ToHyperLinkString(objPATH.ParentFolder)
        RS.Fields("Path") = ToHyperLinkString(objPATH.Path)
        RS.Fields("ShortName") = ToHyperLinkString(objPATH.ShortName)
        RS.Fields("ShortPath") = ToHyperLinkString(objPATH.ShortPath)
        RS.Fields("Size") = objPATH.Size
        RS.Fields("Type") = objPATH.Type
        RS.Update
    Exit Sub
EXCEPTION:
    RS.Fields("処理結果") = "NG"
    RS.Fields("エラー情報") = Err.Number & "    " & Err.Description
    Resume Next
End Sub

Sub WriteFileInfo(ByRef RS As Recordset, ByRef objFILE As File)
    On Error GoTo EXCEPTION
        RS.AddNew
        RS.Fields("処理結果") = "OK"
        RS.Fields("Attributes") = objFILE.Attributes
        RS.Fields("DateCreated") = objFILE.DateCreated
        RS.Fields("DateLastAccessed") = objFILE.DateLastAccessed
        RS.Fields("DateLastModified") = objFILE.DateLastModified
        RS.Fields("Drive") = objFILE.Drive
        RS.Fields("Name") = objFILE.Name
        RS.Fields("ParentFolder") = ToHyperLinkString(objFILE.ParentFolder)
        RS.Fields("Path") = objFILE.Path
        RS.Fields("ShortName") = ToHyperLinkString(objFILE.ShortName)
        RS.Fields("ShortPath") = ToHyperLinkString(objFILE.ShortPath)
        RS.Fields("Size") = objFILE.Size
        RS.Fields("Type") = objFILE.Type
        RS.Update
    Exit Sub
EXCEPTION:
    RS.Fields("処理結果") = "NG"
    RS.Fields("エラー情報") = Err.Number & "    " & Err.Description
    Resume Next
End Sub

Public Function ToBooleanString(ByRef b As Boolean) As String
    If b = True Then
        ToBooleanString = "True"
    Else
        ToBooleanString = "False"
    End If
End Function

Public Function ToHyperLinkString(ByRef str As String) As String
    ToHyperLinkString = ""
    If str <> "" Then
        ToHyperLinkString = "#" & str & "#"
    End If
End Function

使い方とポイント

• SEARCH_FOLDER サブルーチンを実行すると、対象フォルダの入力を促すインプットボックスが表示されます。
• FileSystemObjectの主要なプロパティ（作成日時、最終アクセス日時、サイズ、属性など）を一通り取得し、レコードセット経由でテーブルに蓄積します。
• エラーが発生したレコードは「処理結果」列に「NG」と記録され、処理が中断しないよう Resume Next で継続する設計になっています。