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

「GetFileSystemInfo.zip」をダウンロード

サンプルコード

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
    ‘ 処理開始
   ‘ Cells.ClearContents
    Set objFSO = New FileSystemObject           ‘ FSO
    ‘ ルートフォルダから探索開始
    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

‘*******************************************************************************
‘   フォルダ単位のサブ処理(再帰動作,引数はFile-Object,行,カラム)
‘*******************************************************************************
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                   ‘ 参照フォルダ数を加算

‘    If objPATH.Attributes = (Hidden + System + Directory + Alias) Then
‘        Debug.Print "skip"
‘    end if

    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               ‘ 参照ファイル数
        With objFILE
        End With
        ‘レコード出力（ファイル分）
        Call WriteFileInfo(RS, objFILE)
       
        ‘処理が長い場合にそなえて、一旦ここで処理を突き放す。
        RS.Requery
        DoEvents
    Next objFILE
   
    ‘ 参照OBJECTを破棄
    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

‘            Debug.Print objPATH.Attributes
‘            Debug.Print objPATH.DateCreated
‘            Debug.Print objPATH.DateLastAccessed
‘            Debug.Print objPATH.DateLastModified
‘            Debug.Print objPATH.Drive
‘            Debug.Print objPATH.IsRootFolder
‘            Debug.Print objPATH.Name
‘            Debug.Print objPATH.ParentFolder
‘            Debug.Print objPATH.Path
‘            Debug.Print objPATH.ShortName
‘            Debug.Print objPATH.ShortPath
‘            Debug.Print objPATH.Size
‘            Debug.Print objPATH.Type

    Exit Sub
EXCEPTION:
    RS.Fields("処理結果") = "NG"
    RS.Fields("エラー情報") = Err.Number & "   " & Err.Description & "   " & Err.HelpFile
    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

‘        Debug.Print objFILE.Attributes
‘        Debug.Print objFILE.DateCreated
‘        Debug.Print objFILE.DateLastAccessed
‘        Debug.Print objFILE.DateLastModified
‘        Debug.Print objFILE.Drive
‘        Debug.Print objFILE.Name
‘        Debug.Print objFILE.ParentFolder
‘        Debug.Print objFILE.Path
‘        Debug.Print objFILE.ShortName
‘        Debug.Print objFILE.ShortPath
‘        Debug.Print objFILE.Size
‘        Debug.Print objFILE.Type

    Exit Sub
EXCEPTION:
    RS.Fields("処理結果") = "NG"
    RS.Fields("エラー情報") = Err.Number & "   " & Err.Description & "   " & Err.HelpFile
    Resume Next
End Sub

‘アトリビュート属性のチェック
‘http://msdn.microsoft.com/en-us/library/5tx15443(v=vs.84).aspx
‘Constant    Value   Description
‘Normal  0   Normal file. No attributes are set.
‘ReadOnly    1   Read-only file. Attribute is read/write.
‘Hidden  2   Hidden file. Attribute is read/write.
‘System  4   System file. Attribute is read/write.
‘Volume  8   Disk drive volume label. Attribute is read-only.
‘Directory   16  Folder or directory. Attribute is read-only.
‘Archive 32  File has changed since last backup. Attribute is read/write.
‘Alias   1024    Link or shortcut. Attribute is read-only.
‘Compressed  2048    Compressed file. Attribute is read-only.
Function GetAttributesString(ByVal ThisFileAttribute As FileAttribute) As String
    GetAttributesString = ""
    GetAttributesString = "No=" & ThisFileAttribute & " "
    If ThisFileAttribute And Normal Then
        GetAttributesString = GetAttributesString & "Normal,"
    End If
    If ThisFileAttribute And ReadOnly Then
        GetAttributesString = GetAttributesString & "ReadOnly,"
    End If
    If ThisFileAttribute And Hidden Then
        GetAttributesString = GetAttributesString & "Hidden,"
    End If
    If ThisFileAttribute And System Then
        GetAttributesString = GetAttributesString & "System,"
    End If
    If ThisFileAttribute And Volume Then
        GetAttributesString = GetAttributesString & "Volume,"
    End If
    If ThisFileAttribute And Directory Then
        GetAttributesString = GetAttributesString & "Directory,"
    End If
    If ThisFileAttribute And Archive Then
        GetAttributesString = GetAttributesString & "Archive,"
    End If
    If ThisFileAttribute And Alias Then
        GetAttributesString = GetAttributesString & "Alias,"
    End If
    If ThisFileAttribute And Compressed Then
        GetAttributesString = GetAttributesString & "Compressed,"
    End If

End Function

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

テーブルは、FylesystemObjectのfolderとfileのプロパティ値を、msdnやオブジェクトブラウザを見ながら設計した。

folderとfileにある一通りの情報は抜いてきている。

勉強用だけど、かなり実用的なマクロかもしれない。

あとはフォームやエラー回りを整えると便利になる。