FSO 指定フォルダ内のサブフォルダとファイル(詳細)を列挙(深階層)

※より実装に近く表示させる為、コードの改行を避けています。スマホ等で閲覧される際は向きを変えてご覧ください。

※実装するバージョンによってはバージョンアップの仕様により動作しないコードもあります。実装には動作確認の上ご使用下さい。

Option Explicit

'Microsoft Scripting Runtime(FSO)

Dim sht As Worksheet, cntLow As Long
Dim strExtension As String, lngSize As Long
Dim objMsSR As Object


Sub GetAllSubFolderAndFiles()
'************************************************************
'指定フォルダ内のサブフォルダとファイル(詳細)を列挙(深階層)
'************************************************************

strExtension = "jpg" '*拡張子指定
lngSize = 100 '*サイズ指定

Dim objGFld As Object
Dim strFolderPath As String

strFolderPath = ThisWorkbook.Path
Set sht = ThisWorkbook.Worksheets.Add
Set objMsSR = CreateObject("Scripting.FileSystemObject")
'GetFolderメソッド
Set objGFld = objMsSR.GetFolder(strFolderPath)

cntLow = cntLow + 1
With sht
    sht.Cells(cntLow, 1).Value = "FolderName"
    sht.Cells(cntLow, 2).Value = "FileName"
    sht.Cells(cntLow, 3).Value = "FileSize"
    sht.Cells(cntLow, 4).Value = "作成日時"
    sht.Cells(cntLow, 5).Value = "更新日時"
    sht.Cells(cntLow, 6).Value = "アクセス日時"
    sht.Cells(cntLow, 7).Value = "FolderSize"
End With

'サブルーチン
Call SearchSubFolderAndFiles(objGFld)

Set objMsSR = Nothing

MsgBox "END"

End Sub



Private Sub SearchSubFolderAndFiles(objMainFld As Folder)
'****************
'サブルーチン
'****************
Dim objFld As Folder
Dim objFile As File
Dim strFldName As String
Dim strFldSize As String

strFldName = objMainFld.Name

'ドライブ・ディスクを回避(受付)
If strFldName = "" And objMainFld.Attributes = 22 Then
    '22=Hidden(2)+System(4)+Directory(16)
    For Each objFld In objMainFld.SubFolders
        Call SearchSubFolderAndFiles(objFld)
    Next objFld
'通常フォルダは全て受け付け
ElseIf objMainFld.Attributes = 16 Then
    '16=Directory(16)
    strFldSize = objMainFld.Size
    For Each objFld In objMainFld.SubFolders
        Call SearchSubFolderAndFiles(objFld)
    Next objFld
Else
    GoTo TheEnd:
End If

For Each objFile In objMainFld.Files
    With objFile
       If objMsSR.GetExtensionName(.Path) = strExtension And .Size > lngSize Then
            cntLow = cntLow + 1
            '●Name プロパティ
            'ファイルまたはフォルダ名の取得
            '●Size プロパティ
            'ファイルバイトサイズ・フォルダ合計バイトサイズの取得
            '●DateCreated プロパティ
            'ファイルまたはフォルダ作成日時の取得
            '●DateLastModified プロパティ
            'ファイルまたはフォルダ更新日時の取得
            '●DateLastAccessed プロパティ
            'ファイルまたはフォルダアクセス日時の取得

            sht.Cells(cntLow, 1).Value = strFldName
            sht.Cells(cntLow, 2).Value = .Name
            sht.Cells(cntLow, 3).Value = .Size
            sht.Cells(cntLow, 4).Value = .DateCreated
            sht.Cells(cntLow, 5).Value = .DateLastModified
            sht.Cells(cntLow, 6).Value = .DateLastAccessed
            sht.Cells(cntLow, 7).Value = strFldSize

        End If
    End With
Next objFile

TheEnd:

Set objMainFld = Nothing

'●Attributesプロパティ
'定数        値 内容
'Normal       0 標準ファイル。どの属性も設定されません。
'ReadOnly     1 読み取り専用ファイル。この属性は、値の取得も設定も可能です。
'Hidden       2 隠しファイル。この属性は、値の取得も設定も可能です。
'System       4 システム ファイル。この属性は、値の取得も設定も可能です。
'Volume       8 ディスク ドライブ ボリューム ラベル。この属性は、値の取得のみ可能です。
'Directory   16 フォルダまたはディレクトリ。この属性は、値の取得のみ可能です。
'Archive     32 ファイルが前回のバックアップ以降に変更されているかどうか。この属性は、値の取得も設定も可能です。
'Alias       64 リンクまたはショートカット。この属性は、値の取得のみ可能です。
'Compressed 128 圧縮ファイル。この属性は、値の取得のみ可能です。

End Sub

'###############################################################################

Sub RuntimeFSOSet()
'*************************************************
'FileSystemObject参照設定
'*************************************************
'名称:Microsoft Scripting Runtime

On Error GoTo MyErr:
'参照設定
ThisWorkbook.VBProject.References.AddFromFile "C:\WINDOWS\system32\scrrun.dll"
MyErr:

End Sub

 

2000年01月01日|[VBサンプルコード]:[FSO]