概要
指定フォルダ内のmp3ファイルのプロパティを取得します。
結果はデスクトップに「ファイルリスト_yymmdd_hhmm.xlsx」という名前で出力されます。
ソース
GetDetailsOf メソッドでプロパティを取得しています。（IDはWindows10で確認）
出力しているのは私がよく見るものだけですが、コメントにID書いてあるので、他の項目を出力したい場合はカスタマイズしてください。
Option Explicit
Option Base 1
Dim FilePaths() 'ファイルパス
Sub フォルダ内のMP3の情報を取得する()
'------------------------------------------------------------------------------
'フォルダ内のMP3の情報を取得する
'------------------------------------------------------------------------------
Dim StartTime As Date '開始時刻
StartTime = Now() '開始時刻
Dim EndTime As Date '終了時刻
Dim WSH As Variant 'WSH(Windows Scripting Host)
Dim FSO As Object 'ファイルシステムオブジェクト
Dim DefaultPath As String 'ファイルダイアログのデフォルト表示パス
Dim strFolderPath As String 'ダイアログで指定されたフォルダパス
Dim objFolder As Object 'フォルダオブジェクト
Dim objFiles As Object 'ファイルオブジェクト
Dim objF As Object 'ファイルオブジェクト用for文変数
Dim lngFileCount As Long '処理するファイル数
Dim MsgRtn As String 'メッセージボックスの返り値
Dim intDepth As Integer '階層数
Dim i As Long
Dim k As Long
Dim Shell As Object 'Shell.Application
Dim objShellFolder As Object 'Shell.Namespace
Dim xlsWorkbookOutput As Workbook '結果を出力するExcelファイル
Const strBaseName As String = "ファイルリスト" '結果を出力するファイル名の固定文字列部
Const strExtName As String = "xlsx" '結果を出力するファイル名の拡張子
Dim strDate As String '結果を出力するファイル名の日時部
Dim strOutputFileName As String '結果を出力するファイル名
Const intColHeadColer As Long = 12566463 '表見出しの色（グレー「白、背景 1、黒 + 基本色 25%」）
Dim x As Long '出力列
Dim y As Long '出力行
Dim temp As Long '一時領域（ソート用、デフォルトシート数）
'--------------------------------------
'開始メッセージ
'--------------------------------------
MsgRtn = MsgBox("処理を開始しますか？" & vbCrLf & vbCrLf, _
vbOKCancel + vbInformation, Title:="開始")
If MsgRtn = vbCancel Then Exit Sub
'--------------------------------------
'フォルダを取得
'--------------------------------------
'フォルダダイアログ
Set WSH = CreateObject("WScript.Shell")
DefaultPath = WSH.SpecialFolders("Desktop") & "\" 'デスクトップ。"\"まで入れる。
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = DefaultPath 'デフォルトフォルダをデスクトップにする
If .Show = True Then
strFolderPath = .SelectedItems(1)
End If
End With
'フォルダダイアログで「キャンセル」したので終了
If strFolderPath = "" Then Exit Sub
'フォルダ取得
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = FSO.GetFolder(strFolderPath)
'--------------------------------------
'階層数の指定
'--------------------------------------
Do
MsgRtn = InputBox("階層数を指定してください。" & vbCrLf & vbCrLf & _
"※指定したフォルダの階層を1として、何階層下まで取得するか指定します。デフォルトは1です。", _
"階層数の指定", 1)
'キャンセル
If MsgRtn = "" Then
Exit Sub
End If
'数字
If IsNumeric(MsgRtn) = True Then
'0以下
If MsgRtn <= 0 Then
'もう1度入力
MsgBox "1以上の数値を入力してください。", _
vbOKOnly + vbExclamation, Title:="エラー"
'5以上
ElseIf MsgRtn >= 5 Then
intDepth = CInt(MsgRtn)
MsgRtn = MsgBox(MsgRtn & " 階層が指定されました。ファイルが多い場合には時間がかかりますが、続行しますか？", _
vbOKCancel + vbInformation, Title:="5階層以上指定")
If MsgRtn = vbOK Then
Exit Do
End If
'それ以外
Else
intDepth = CInt(MsgRtn)
Exit Do
End If
'数字以外
Else
MsgBox "1以上の数値を入力してください。", _
vbOKOnly + vbExclamation, Title:="エラー"
End If
Loop
'--------------------------------------
'ファイルリスト取得
'--------------------------------------
Erase FilePaths 'ファイルリスト用変数を初期化
'ファイルリスト取得を呼び出す
GetMP3FileList objFolder, intDepth, 0
On Error Resume Next
lngFileCount = UBound(FilePaths) 'ファイルが1つもない場合UBoundがエラーになる
If Err.Number <> 0 Then
'終了メッセージ
MsgBox "指定されたフォルダにはファイルが1つもないので、終了します。", _
vbOKOnly + vbExclamation, Title:="エラー"
Exit Sub
End If
On Error GoTo 0
'--------------------------------------
'ファイルパスをソート
'--------------------------------------
For i = 1 To lngFileCount
For k = lngFileCount To 1
If FilePaths(i) > FilePaths(k) Then
temp = FilePaths(i)
FilePaths(i) = FilePaths(k)
FilePaths(k) = temp
End If
Next k
Next i
'--------------------------------------
'出力ファイル作成
'--------------------------------------
'カーソル砂時計表示
Application.Cursor = xlWait
'新規ブック作成
temp = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set xlsWorkbookOutput = Workbooks.Add
Application.SheetsInNewWorkbook = temp
'シート名
xlsWorkbookOutput.ActiveSheet.Name = "ファイルリスト"
'フォント
xlsWorkbookOutput.Styles("Normal").Font.Name = "ＭＳ ゴシック"
'ルートフォルダ名をA1に出力
With xlsWorkbookOutput.ActiveSheet.Cells(1, 1)
.NumberFormatLocal = "@"
.Value = strFolderPath
End With
'列の幅・見出し設定
x = 3
y = 1
xlsWorkbookOutput.ActiveSheet.Columns(1).ColumnWidth = 4
xlsWorkbookOutput.ActiveSheet.Columns(2).ColumnWidth = 30
xlsWorkbookOutput.ActiveSheet.Columns(3).ColumnWidth = 70
xlsWorkbookOutput.ActiveSheet.Columns(4).ColumnWidth = 8
xlsWorkbookOutput.ActiveSheet.Columns(5).ColumnWidth = 9
xlsWorkbookOutput.ActiveSheet.Columns(6).ColumnWidth = 8
xlsWorkbookOutput.ActiveSheet.Columns(7).ColumnWidth = 40
xlsWorkbookOutput.ActiveSheet.Columns(8).ColumnWidth = 25
xlsWorkbookOutput.ActiveSheet.Columns(9).ColumnWidth = 25
xlsWorkbookOutput.ActiveSheet.Columns(10).ColumnWidth = 6
xlsWorkbookOutput.ActiveSheet.Columns(11).ColumnWidth = 20
xlsWorkbookOutput.ActiveSheet.Cells(x, 1) = "No"
xlsWorkbookOutput.ActiveSheet.Cells(x, 2) = "サブフォルダ"
xlsWorkbookOutput.ActiveSheet.Cells(x, 3) = "ファイル名"
xlsWorkbookOutput.ActiveSheet.Cells(x, 4) = "サイズ(MB)"
xlsWorkbookOutput.ActiveSheet.Cells(x, 4).ShrinkToFit = True '縮小して全体を表示する
xlsWorkbookOutput.ActiveSheet.Cells(x, 5) = "長さ"
xlsWorkbookOutput.ActiveSheet.Cells(x, 6) = "トラック番号"
xlsWorkbookOutput.ActiveSheet.Cells(x, 6).ShrinkToFit = True '縮小して全体を表示する
xlsWorkbookOutput.ActiveSheet.Cells(x, 7) = "タイトル"
xlsWorkbookOutput.ActiveSheet.Cells(x, 8) = "参加アーティスト"
xlsWorkbookOutput.ActiveSheet.Cells(x, 9) = "アルバム"
xlsWorkbookOutput.ActiveSheet.Cells(x, 10) = "年"
xlsWorkbookOutput.ActiveSheet.Cells(x, 11) = "ジャンル"
'サイズ(MB)の書式
xlsWorkbookOutput.ActiveSheet.Columns("D:D").NumberFormatLocal = "0.0_ "
'表見出しの背景色
xlsWorkbookOutput.ActiveSheet.Range(Cells(x, 1), Cells(x, 11)).Interior.Color = intColHeadColer
'印刷設定
Application.PrintCommunication = False
With xlsWorkbookOutput.ActiveSheet.PageSetup
.PrintTitleRows = "$1:$3"
.CenterFooter = "&P"
.Orientation = xlLandscape
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With
Application.PrintCommunication = True
'--------------------------------------
'出力ファイル保存
'--------------------------------------
strDate = Format(Now(), "_yymmdd-hhmm")
strOutputFileName = strBaseName & strDate
i = 0
Do
If FSO.FileExists(DefaultPath & "\" & strOutputFileName & "." & strExtName) = False Then
Exit Do
Else
'ファイル名
i = i + 1
strOutputFileName = strBaseName & strDate & "_" & i
End If
Loop
'ファイルを保存
xlsWorkbookOutput.SaveAs Filename:=DefaultPath & strOutputFileName & "." & strExtName
'--------------------------------------
'MP3の情報取得して出力
'--------------------------------------
Set Shell = CreateObject("Shell.Application")
For i = 1 To lngFileCount
'ファイルを保存（入力20ファイルごとに出力ファイルを保存）
If i Mod 20 = 0 Then
xlsWorkbookOutput.Save
End If
'ステータスバー表示
Application.StatusBar = Left(Format(i / lngFileCount, "0.0%") & " (" & i & "/" & lngFileCount & ") " & FilePaths(i), 125)
DoEvents
'--------------------------------------
'結果をExcelに出力
'--------------------------------------
'出力行
x = x + 1
'No
xlsWorkbookOutput.ActiveSheet.Cells(x, y) = i
'フォルダ名（ルートフォルダは出力しない）
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 1).NumberFormatLocal = "@"
If FSO.GetParentFolderName(FilePaths(i)) = strFolderPath Then
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 1) = Replace(FSO.GetParentFolderName(FilePaths(i)), strFolderPath, "")
Else
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 1) = Replace(FSO.GetParentFolderName(FilePaths(i)), strFolderPath & "\", "")
End If
'ファイル名
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 2).NumberFormatLocal = "@"
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 2) = FSO.GetFilename(FilePaths(i))
'サイズ(MB)
If FSO.GetFile(FilePaths(i)).Size > 0 Then
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 3) = FSO.GetFile(FilePaths(i)).Size / 1024 / 1024
End If
' xlsWorkbookOutput.ActiveSheet.Cells(x, y + 3) = & FileLen(FilePaths(i)) /1024/1024 'ファイル名に日本語または英語以外が含まれるとサイズ取得がエラーになる（例：フランス語のアクサン記号とか）
Set objShellFolder = Shell.Namespace(FSO.GetParentFolderName(FilePaths(i)))
With objShellFolder
'GetDetailsOfのID（Windows 10の場合）
'0,名前
'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以降もあるが、使わないと思われるので、ここまで）
'長さ
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 4) = .GetDetailsOf(.ParseName(FSO.GetFilename(FilePaths(i))), 27)
'トラック番号
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 5) = .GetDetailsOf(.ParseName(FSO.GetFilename(FilePaths(i))), 26)
'タイトル
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 6) = .GetDetailsOf(.ParseName(FSO.GetFilename(FilePaths(i))), 21)
'参加アーティスト
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 7) = .GetDetailsOf(.ParseName(FSO.GetFilename(FilePaths(i))), 13)
'アルバム
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 8) = .GetDetailsOf(.ParseName(FSO.GetFilename(FilePaths(i))), 14)
'年
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 9) = .GetDetailsOf(.ParseName(FSO.GetFilename(FilePaths(i))), 15)
'ジャンル
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 10) = .GetDetailsOf(.ParseName(FSO.GetFilename(FilePaths(i))), 16)
End With
Set objShellFolder = Nothing
Next i
'--------------------------------------
'終了
'--------------------------------------
'ステータスバー表示デフォルト
Application.StatusBar = False
'カーソル砂時計表示
Application.Cursor = xlDefault
'ファイルを保存
xlsWorkbookOutput.Save
'ウィンドウアクティブ
AppActivate Application.Caption
'終了メッセージ
EndTime = Now() '終了時刻
MsgBox "終了しました。" & vbLf & vbLf & _
"処理時間：" & Format(EndTime - StartTime, "hh:mm:ss") & vbLf & _
"出力ファイル：" & DefaultPath & xlsWorkbookOutput.Name & vbCrLf & vbCrLf, _
vbOKOnly + vbInformation, Title:="終了"
'オブジェクトクリア
Set WSH = Nothing
Set FSO = Nothing
Set objFolder = Nothing
Set objFiles = Nothing
Set objF = Nothing
Set xlsWorkbookOutput = Nothing
Set Shell = Nothing
Set objShellFolder = Nothing
End Sub
Sub GetMP3FileList(objFolder As Object, intDepth As Integer, lngFileCount As Long)
'--------------------------------------
'ファイルリスト取得（再帰呼び出し）
' 結果はモジュールレベル変数「FilePaths」に格納
'--------------------------------------
Dim objSubFolder As Object 'サブフォルダ
Dim objFiles As Object 'ファイル
Dim objF As Object '変数
Dim intNextDepth As Integer '次の階層数
Dim i As Long
Dim FSO As Object 'ファイルシステムオブジェクト
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objSubFolder = objFolder.subFolders
Set objFiles = objFolder.Files
intNextDepth = intDepth - 1
'フォルダ配下
'objSubFolder.Countがとれない特殊フォルダは配下ごと無視
On Error Resume Next
i = objSubFolder.Count
If Err.Number = 0 Then
If objSubFolder.Count > 0 Then
For Each objF In objSubFolder
If intNextDepth > 0 Then
'再帰呼び出し
GetMP3FileList objF, intNextDepth, lngFileCount
End If
Next objF
End If
End If
'ファイル
If objFiles.Count > 0 Then
For Each objF In objFiles
If objF Is Nothing Then
'システム系でNothingが返ってくることがあるので飛ばす
ElseIf Left(objF.Name, 2) = "~$" Then
'~$で始まる一時ファイルは後のページ数取得がエラーになるので飛ばす
ElseIf Left(objF.Name, 1) = "$" Then
'$で始まるファイルは後のページ数取得がエラーになるので飛ばす
ElseIf LCase(FSO.GetExtensionName(objF.Name)) = "mp3" Then
'ファイルカウント
lngFileCount = lngFileCount + 1
'ファイルパスを取得するための動的配列を定義
If lngFileCount = 1 Then
ReDim FilePaths(lngFileCount)
Else
ReDim Preserve FilePaths(lngFileCount)
End If
'ファイルパスを配列に格納
FilePaths(lngFileCount) = objF
Else
'他のファイルは読まない
End If
Next objF
End If
Set objSubFolder = Nothing
Set objFiles = Nothing
Set objF = Nothing
End Sub
補足
2021/7/31 380行目のコード（再帰呼び出しのメソッド名）が誤っていましたので、修正しました。ご報告いただいた方、ご連絡ありがとうございました。
