指定したディレクトリのファイルを表示

あるディレクトリのファイル名を見る場合、普通はエクスプローラをみると思います。しかし、ディレクトリ内のファイルの一覧を作成したいときもあると思います。そのような場合は一つの方法としてコマンドプロンプトからdirコマンドを実行しテキストファイルにまとる方法があります。今回はexcelシートにファイル名の一覧を出力するプログラムをコーディングしてみました。

ポイントとしては以下です。

Sub aaa()     Dim objFS As FileSystemObject     Set objFS = CreateObject("Scripting.FileSystemObject")  '←FileSystemObject生成     Dim objFile As File     For Each objFile In objFS.GetFolder("C:\work").Files         MsgBox objFile.Path     Next     Set objFS = Nothing     '←FileSystemObject解放 End Sub

FileオブジェクトのPathプロパティを参照しました。objFS.GetFolder("C:\work")で「C:\work」のオブジェクトを取得しています。Filesでフォルダ配下のファイルをFileオブジェクトにわたしてループしています。
今回はサブフォルダ内のファイルも再帰的に表示させるようにしました。(フォルダを渡すと配下のファイルを表示させるメソッドで、サブフォルダを自メソッドに渡しています。)
また、ファイル数が500件を超えた場合、処理を中止するようにしました。500件である意味はないですが、ファイル数が多すぎるとやはりだめみたいです。




これは、使えるかも？！

Option Explicit Public Sub showFile1()     '--------------------------------------------------------     '初期処理     '--------------------------------------------------------     'A1セルの文字列を取得     Dim dPath As String     dPath = Cells(1, "A").Value     'A1セルの文字列の最後に「\」がなかったら付加する     If Right(dPath, 1) <> "\" Then         dPath = dPath & "\"     End If     'A1セルの文字列の長さを取得     Dim dPathLen As Integer     dPathLen = Len(dPath)     '--------------------------------------------------------     'ディレクトリ存在の確認     '--------------------------------------------------------     'ディレクトリが存在しない又はファイルが指定されている場合     If Dir(dPath, vbDirectory) = "" Or (GetAttr(dPath) And vbDirectory) <> vbDirectory Then         '存在しない場合はメッセージ出して終了         MsgBox "ディレクトリが存在しません"         Exit Sub     End If     '--------------------------------------------------------     'FileSystemオブジェクトの生成     '--------------------------------------------------------     Dim objFS As FileSystemObject     Set objFS = CreateObject("Scripting.FileSystemObject")     '--------------------------------------------------------     'フォルダ内のファイル名を表示     '--------------------------------------------------------     Dim objFile As File     Dim y As Integer     Dim fPath As String     y = 2   '←2行目から表示させる     '指定ディレクトリのファイル数分ループ     On Error GoTo SHOWFILE1_ERR   'エラーが発生したら「:SHOWFILE1_ERR」にとぶ     For Each objFile In objFS.GetFolder(dPath).Files         '500ファイルを超えたらエラーにする         If y - 1 > 500 Then             MsgBox "500ファイルを超えたので終了します。"             'オブジェクトの解放             Set objFS = Nothing             Exit Sub         End If         Cells(y, 1).Value = y - 1   '←A列に項番(表示列-1)を表示         'A1文字列を抜いたファイルパスを取得する         fPath = Right(objFile.Path, Len(objFile.Path) - dPathLen)         Cells(y, 2).Value = fPath   '←B列にファイル名を表示         y = y + 1     Next     On Error GoTo 0     '--------------------------------------------------------     'サブフォルダを取得しshowFile2()にわたす     '--------------------------------------------------------     'ユーザーにサブフォルダのファイルも表示もさせるか確認する。     Dim res As Integer     res = MsgBox("サブフォルダのファイルも表示しますか?", vbYesNo)     '回答が「はい」の場合     If res = vbYes Then         Dim errStr As String         Dim objSubFol As Folder         'サブフォルダ数分ループ         For Each objSubFol In objFS.GetFolder(dPath).SubFolders             errStr = showFile2(objSubFol, y, dPathLen)    '←サブフォルダを引数としてshowFile2呼び出し             If errStr <> "" Then GoTo SHOWFILE2_ERR     '戻り値にメッセージがある場合は「SHOWFILE2_ERR」に飛ぶ         Next     End If     '--------------------------------------------------------     '終了処理     '--------------------------------------------------------     'オブジェクトの解放     Set objFS = Nothing     '完了メッセージ     MsgBox y - 2 & "件表示しました。"   '行数から1行目と最後のループカウンタをぬく     Exit Sub SHOWFILE1_ERR:     'オブジェクトの解放     Set objFS = Nothing     'エラーメッセージ     MsgBox "ファイル表示処理でエラーが発生しました。"     Exit Sub SHOWFILE2_ERR:     'オブジェクトの解放     Set objFS = Nothing     'エラーメッセージ     MsgBox errStr     Exit Sub End Sub Private Function showFile2(ByRef objFol As Folder, ByRef y As Integer, ByRef dPathLen As Integer)     On Error GoTo ERR     '--------------------------------------------------------     'フォルダ内のファイル名を表示     '--------------------------------------------------------     Dim objFile As File     Dim fPath As String     '指定ディレクトリのファイル数分ループ     For Each objFile In objFol.Files         '500ファイルを超えたらエラーにする         If y - 1 > 500 Then             showFile2 = "500ファイルを超えたので終了します。"             Exit Function         End If         Cells(y, 1).Value = y - 1   '←A列に項番(表示列-1)を表示         '↓A1文字列と「\」を抜いたファイルパスを取得する         fPath = Right(objFile.Path, Len(objFile.Path) - dPathLen)         Cells(y, 2).Value = fPath   '←B列にファイル名を表示         y = y + 1     Next     '--------------------------------------------------------     'サブフォルダを取得しshowFile2()にわたす(自プロシージャ呼び出し)     '--------------------------------------------------------     Dim objSubFol As Folder     'サブフォルダ数分ループ     For Each objSubFol In objFol.SubFolders         Call showFile2(objSubFol, y, dPathLen)      '←サブフォルダを引数としてshowFile2呼び出し     Next     On Error GoTo 0     'エラーが無ければNull文字をかえす     showFile2 = ""     Exit Function ERR:     'エラーが発生した場合は文字列をかえす     showFile2 = "showFile2でエラーが発生しました。"     Exit Function End Function