★ 指定したフォルダ内の、すべてのサブフォルダを延々と掘っていって、『 すべてのファイルとすべてのサブフォルダ 』の基本情報を指定したシートにゲットする(吸い込む)プログラム。(再帰的な処理)
以降に挙げたプログラムを標準モジュールに単純にALLコピペして、
「GetFolderAndFileListMain02」のほうだけを実行します。
なお、このプログラムを、他のプログラムに流用したい場合は、
「GetFolderAndFileListMain02」のほうの
「o_ImpWs01.Cells.ClearContents」から「End With '↑列名(項目名)を書き込む」というところまでをカットし、
「GetFolderAndFileListSub」のほうの
2つのFor Each のループの中を、書き換えます。
ただその場合、「GetFolderAndFileListSub」のほうは、
基本、
1つ目のFor Each のループ(サブフォルダのみに対する処理)は、
For Each myFolder In FSO.GetFolder(s_folderPath).subfolders
Call GetFolderAndFileListSub(o_ImpSheet, myFolder.Path, myCount)
Next myFolder
の3行だけがあればOKです。
下記のプログラムでは、事例として「サブフォルダの内容もゲットしたい」ということでやりましたので色々書いてありますが、
通常は、「ファイルたち」「だけ」に何かしたい場合が多いので、
その場合は、
2つ目のFor Each のループの内容だけ書き換えて(あるいは関数化して)、
1つ目のFor Each のループは、上記の3行だけがあればOKです。
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 |
' ' Option Explicit '#################################################### 'すべてのファイルとフォルダの情報を調べたい、 'その「フォルダ」と、 'その情報を吸い込みたいシートを指定する処理。 '#################################################### Sub GetFolderAndFileListMain02() Dim o_AnswFDialg As FileDialog Dim s_PickFldPath As String Dim o_ImpWs01 As Worksheet '★ 設定部 ' s_FoldPath = "D:\1" Set o_AnswFDialg = Application. _ FileDialog(msoFileDialogFolderPicker) '↑ファイル選択ダイアログを使えるように準備。 ' Set o_ImpWs01 = Application. _ Workbooks.Item("ブック名"). _ ' Worksheets.Item("シート名") Set o_ImpWs01 = ActiveWorkbook. _ ActiveSheet '↑ファイル情報を吸い込むシートを指定。 '★ 実動部 If Not o_AnswFDialg.Show Then Exit Sub '↑キャンセルされたときは終わる。 Else s_PickFldPath = o_AnswFDialg.SelectedItems(1) '↑フォルダが選択されたら、 ' ファイル選択ダイアログのオブジェクトの「SelectedItems プロパティ」にフォルダパスが自動的にゲットされるので、 ' 一時的な処理として、いったん適当な変数にそれをメモ代入。 End If '↑ファイル選択ダイアログを実際に開き、 ' フォルダが選択されたら(=フォルダパスがゲットできたら) ' そのパスを一時保管して次へ行き、 ' キャンセルされたらプログラムを終わる。 o_ImpWs01.Cells.ClearContents '↑いったん、指定したシートをオールクリアして真っ白にする。 With o_ImpWs01 .Range("A1") = "パス" .Range("B1") = "容量(KB)" .Range("C1") = "種類" .Range("D1") = "作成日時" .Range("E1") = "アクセス日時" .Range("F1") = "更新日時" End With '↑列名(項目名)を書き込む ' Call getFolderAndFileListSub(folderPath:=s_FoldPath) Call GetFolderAndFileListSub(o_ImpSheet:=o_ImpWs01, _ s_folderPath:=s_PickFldPath) '↑リスト作成の実行。 ' ピックアップされたフォルダバスの中を、 ' すべてのサブフォルダのすべてのファイルを対象に、 ' o_ImpWs01 に指定したシートにファイル情報を吸い込む(=書き込む)。 End Sub '#################################################### '実際にすべてのサブフォルダたちとファイルたちの、 'ファイルとフォルダの基本情報を、 '指定したシートに吸い込む処理。 '#################################################### Sub GetFolderAndFileListSub(o_ImpSheet As Worksheet, _ s_folderPath As String, _ Optional myCount As Long = 1) ' Dim fso As New FileSystemObject '←参照設定しないように作り変えたのでコメントアウト Dim FSO As Object ' Dim o_FolderItem As Folder '←参照設定しないようにしたのでコメントアウトして次行のように書き換え Dim o_FolderItem As Object ' Dim o_FileItem As File '←参照設定しないようにしたのでコメントアウトして次行のように書き換え Dim o_FileItem As Object ' Dim Ws01 As Worksheet '←情報を吸い込むシートも引数化したのでコメントアウト '★ 設定部 Set FSO = CreateObject("Scripting.FileSystemObject") '↑参照設定しなくてもFSO(FileSystemObject)を使えるようにする。 ' Set Ws01 = ActiveWorkbook.ActiveSheet '←情報を吸い込むシートも引数にしたのでコメントアウト On Error Resume Next '★ 実働部 'サブフォルダを再帰的に覗いていって処理。 For Each o_FolderItem In FSO.GetFolder(s_folderPath).subfolders myCount = myCount + 1 'ファイル情報を吸い込みたいシートの、 'どの行に書き込みたいかを設定する ' With Ws01 With o_ImpSheet .Cells(myCount, 1) = o_FolderItem.Path & "\ (DIR)" 'サブフォルダのフルパスの書込み。「(DIR)」という目印あり。 ' .Cells(myCount, 1) = o_FolderItem.Path '同上。目印なし。 ' .Cells(myCount, 2) = Int(o_FolderItem.Size / 1024) 'サブフォルダのKBでの容量(整数。右クリックプロパティの「サイズ」の値に合わせない。) .Cells(myCount, 2) = Round(o_FolderItem.Size / 1024, 1) 'サブフォルダのKBでの容量(小数。右クリックプロパティの「サイズ」の値に合わせる。「詳細表示」のリスト表示の「サイズ」の値とは異なります。) .Cells(myCount, 3) = o_FolderItem.Type 'オブジェクトの種類(フォルダ、××ファイル、など) .Cells(myCount, 4) = o_FolderItem.DateCreated 'サブフォルダの作成日 .Cells(myCount, 5) = o_FolderItem.DateLastAccessed 'サブフォルダの最終アクセス日時 .Cells(myCount, 6) = o_FolderItem.DateLastModified 'サブフォルダの最終更新日 End With '↑ファイル情報を吸い込みたいシートに、具体内容を吸い込む。 Call GetFolderAndFileListSub(o_ImpSheet, o_FolderItem.Path, myCount) '↑サブフォルダのサブフォルダを、(再帰的に)終わるまでどんどん掘っていく。 ' サブフォルダが見つかるたびに、更に掘っていく。 Next o_FolderItem '↑「サブフォルダのみを延々と深く最後まで掘っていくループ ' (この段階ではサブフォルダのフォルダ情報のみをゲット。 ' サブフォルダ内のファイルたちの情報は次の段階のForEachループでゲット。) ' '現在のフォルダの中「だけ」の、ファイル一覧の書き出し。(サブフォルダも含む) 'コメント内容は前述の「サブフォルダ延々掘り」のときとおおむね同じ。(フォルダ情報がファイル情報になっただけ) For Each o_FileItem In FSO.GetFolder(s_folderPath).Files myCount = myCount + 1 ' With Ws01 With o_ImpSheet .Cells(myCount, 1) = o_FileItem.Path 'ファイルのフルパスを書き込む ' .Cells(myCount, 2) = Int(o_FileItem.Size / 1024) 'ファイルの容量(整数。KB単位。プロパティの「サイズ」の値に合わせない。) .Cells(myCount, 2) = Round(o_FileItem.Size / 1024, 1) 'ファイルの容量(小数。KB単位。プロパティの「サイズ」の値に合わせる。「詳細表示」のリスト表示の「サイズ」の値とは異なります。) .Cells(myCount, 3) = o_FileItem.Type 'ファイルの種類 .Cells(myCount, 4) = o_FileItem.DateCreated 'ファイルの作成日 .Cells(myCount, 5) = o_FileItem.DateLastAccessed 'ファイルの最終アクセス日 .Cells(myCount, 6) = o_FileItem.DateLastModified 'ファイルの最終更新日 End With Next o_FileItem End Sub ' ' |
- 投稿タグ
- 「ニセモノ」への道, 「本物」に近づくために, AccessVBA, Accessの独学, Access操作の基礎, Accesの独学, ADO/DAO, ExcelSQL, ExcelVBA, Excelの独学, Excel操作の基礎, Excel連携VBA, MicrosoftQuery, ODBC, SQL, パソコンでの自動化, ビジネスパソコンの基礎, ビジネス一般常識, マクロ, ワークシート関数, 独学, 自動化