VBAで所有するMp3の一覧（データベース）を作成

質問

所有するMp3の一覧（データベース）を作成したいと思います。

１）excel（VBA)でMP3のタグ情報を参照するして
　一つの行にファイル名（フルパス）、サイズ、種類、アーティスト、アルバム名などを表記した形式を想定しています。

２）対象のファイル（MP3)は、
　あるディレクトリを選択するとそれ以下にある全ての階層を順番に読み込みたいと思っています。
　　　（読み込み対象は、拡張子がmp3のみ）

以下を参考にできそうですが、
　階層を順番に読み込むにはどうしたら良いでしょうか　？

MP3の「曲の長さ」を調べる
http://officetanaka.net/other/extra/tips16.htm

--------------
環境
windows10+office2019

回答No.10

asciiz

＞　　提示いただいた関数及び追加コードを付加してマクロを起動しましたが
＞　　同じエラーが発生しました。

ううむ駄目でしたか、まあ何となく原因は文字コード(SJIS/UTF-16あたり)にありそうな気はするんですが…。

・Windows7あたりから、ファイル名にはUnicodeが使用できる
・しかしExcelの内部的には、歴史的な経緯からShuft-JIS前提なところがある
・VBAはUTF-16なのでUnicodeを受け取れるが、シート名にしようとすると内部でShift-JISに変換されたところで「??」が発生してしまい、エラーになる。

みたいな想像を。

で、こんな記事がありました、

＞VBA Unicode 文字の入力や変換、読み込みについて
＞https://www.tipsfound.com/vba/04012

詳しく知りたければじっくり読んでもらうとして、シフトJISとUnicodeを変換できる関数があります。
なので、Function RemoveKinsoku に入った最初で、

name = StrConv(name, vbFromUnicode) ' UTF-16 を Shift_JIS に変換
name = StrConv(name, vbUnicode) ' Shift_JIS を UTF-16 に変換

とやってみてはどうでしょう。

関数パラメータの "Cusco - Desert" (UTF-16)
シフトJIS化 → "Cusco ?? Desert" (SJIS)
再度Unicode化 → "Cusco ?? Desert" (UTF-16)
禁則文字の削除 → "Cusco Desert" (UTF-16)

となってくれますかね…。

お礼

asciizさん、「補足」（2021/04/01 11:30)関連で
　　以後分かったことが有るので関係有るかよく分かりませんが、
　　「お礼する」の欄に記載しました。
　　　（補足に追加、修正できれば良いのでしょうが出来ないので。。。）

以前別のvbaでツールを作成した時に
.Pattern= で[]の中に入れる文字コードを指定するのに
　　その文字コードが何であるかチェックするのに以下の関数でチェックしました。

（関数自体は、他の方から教えてもらいました。

B1：　　=DEC2HEX(UNICODE(A1))

問題の？？をA1に入れるとB1は
　　20
と表示されます。

「-」マイナスをA1に入れるとB1は
　　2D
と表示されます。

----------------------------------
「20」はなんだろうと？　と

参考になる下記サイトを見つけたので
　　「20」があるか見てみましたが見つかりませんでした。

ハイフンに似てる文字の文字コード
https://qiita.com/ryounagaoka/items/4cf5191d1a2763667add

補足

アドバイスありがとうございます。

処理されないのは文字コードが関係するかも知れないのですね。

アドバイスされた追加のコードを追加しました。
　（Dim行の次に追加したのですが、この位置で良いのでしょうか　？
　　　　添付した現在のコードを参照ください。

　　　何度もコードを個人でコードを追加/修正したので
　　　　　おかしな点があるかも知れません。。。。。）

コードを追加後、強大なフォルダ（MP3）をテストするのは、
　時間の無駄なので問題が有るフォルダーを入れた容量が少なめの以下の
　３つのフォルダーでテストしました。

　３つ共にエラー無く処理は終了しましたが、
　　　書き出されたシートの内容が変です。
　　　　　（書き出されないMP3があります。）

現在の状態は、正直手に余る現象なので思考停止しています。

以下分かりにくい説明ですが
　　詳細を説明します。

--------------------------
フォルダー構造
　　Mp3（X)のXは、そのフォルダーに入っているMp3の総数を表します。
　　Mp3(x)　の後に続く　--　の後の数値は　シートに書き出した
　　　　内容を説明するための個別に付けた数値です。

J:\#Song_t
　J:\#Song_t\#Sky 1-4
　　J:\#Song_t\#Sky 1-4\SKY - Sky (1979) (Expanded & Remastered, 2014)
Mp3(9) --- 1
　　J:\#Song_t\#Sky 1-4\SKY - Sky 2 (1980) (Expanded & Remastered, 2014)
Mp3(13) -- 2

　J:\#Song_t\Airborne - Cool Breeze - 202
Mp3(14) -- 3

　J:\#Song_t\Cusco 3 Cd's
　　J:\#Song_t\Cusco 18 Cd's\1981 Cusco - Cusco 2 (1981)　　　　-----＞　置き換え済み
　　　　　　Mp3（12）-- 4
　　J:\#Song_t\Cusco 18 Cd's\1982 Cusco ‎– Planet Voyage (1982)　------＞　未処理
　　　　　　Mp3(10) -- 5
　　J:\#Song_t\Cusco 18 Cd's\1983 Cusco ‎– Virgin Islands (1983)　-----＞　未処理
Mp3(12) -- 6

------------------
ターゲットフォルダーを1),2),3)に指定して
　Mp3がシートに書き出された結果

1)Song_t
Mp3 -----> 4 + 3の12曲中の2曲のみ(後10曲は入っていない）
　　　　　　　1,2 が入っていない

2)Airborne
Mp3　----->　3　（14曲全て）
3)#Sky 1-4
Mp3 ------> 2（13曲全て）
1　が入るはずなの全く入っていない

置き換えしていない（未処理）の
　　5，6が入らないのは当然だと思います

置き換えとは、以前説明した
　”ー”の部分（前後の空白らしき部分も含めて）を削除して
　　改めて　半角空白と(-)マイナスで置き換える処理のことです。

-----------------------------------------------------
現在のコードです。
Dim cnt As Long

Sub Sample3(Path As String)
Dim buf As String
Dim f As Object
Dim SHell As Variant

Set SHell = CreateObject("Shell.Application")
Dim Folder As Variant
Set Folder = SHell.Namespace(Path & "\")

buf = Dir(Path & "\*.mp3")

Cells(1, 3) = "曲名"
Cells(1, 4) = "パス"
Cells(1, 1) = "アーチスト"
Cells(1, 2) = "アルバム"
Cells(1, 5) = "制作年"
Cells(1, 6) = "ジャンル"

Range("A1:F1").Font.Bold = True

cnt = 1
Do While buf <> ""
cnt = cnt + 1

Cells(cnt, 3) = buf '曲名
Cells(cnt, 4) = Path 'パス
Cells(cnt, 1) = Folder.GetDetailsOf(Folder.ParseName(buf), 20) 'アーチスト
Cells(cnt, 2) = Folder.GetDetailsOf(Folder.ParseName(buf), 14) 'アルバム
Cells(cnt, 5) = Folder.GetDetailsOf(Folder.ParseName(buf), 15) '年
Cells(cnt, 6) = Folder.GetDetailsOf(Folder.ParseName(buf), 16) 'ジャンル
buf = Dir()
Loop
With CreateObject("Scripting.FileSystemObject")
For Each f In .GetFolder(Path).SubFolders
Call Sample3(f.Path)
Next f
End With

Columns("A:F").AutoFit

End Sub

Sub Test()
Dim buff As String
Dim sh As Object

cnt = 1
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
buff = .SelectedItems(1)
End With

Dim NewName As String
NewName = Mid(buff, InStrRev(buff, "\") + 1)

NewName = RemoveKinsoku(NewName)
NewName = Left(NewName, 31)

'同名のシートがあれば削除して新たに挿入する
For Each sh In Worksheets
If sh.name = NewName Then
Application.DisplayAlerts = False
On Error GoTo Err_Line
sh.Delete
Application.DisplayAlerts = True
End If
Next sh

Set NewWorkSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
NewWorkSheet.name = NewName

Call Sample3(buff)

Exit Sub
'エラー処理
Err_Line:
If Err.Number = 1004 Then
MsgBox "同名フォルダーしか無いのでフォルダーは削除できません。" & vbCrLf & _
" (少なくとも空ディレクトリーが1つ必要です。"

End If
End Sub

Function RemoveKinsoku(name As String) As String
Dim KinsokuList() As String

name = StrConv(name, vbFromUnicode) ' UTF-16 を Shift_JIS に変換
name = StrConv(name, vbUnicode) ' Shift_JIS を UTF-16 に変換

KinsokuList = Split("',"",*,:,?,\,[,],/,＼,<,>", ",")

Dim cha

回答No.9

asciiz

＞sh.Delete
＞実行エラー　1004
＞　WorksheetクラスのDeleteメソッドが失敗しました。

うーん? こちらでは問題なく実行できていましたが…その「??」になってしまう文字のせいであるかもしれません。

そこで、

＞【ExcelVBA】文字列からシート名に使えない文字を消去する - 和風スパゲティのレシピ
＞https://www.limecode.jp/archive/2021/01/22

こちらを参考に、禁則文字を削除する関数を作ってみました。

Function RemoveKinsoku(name As String) As String
Dim KinsokuList() As String
KinsokuList = Split("',"",*,:,?,\,[,],/,＼,<,>", ",")

Dim char As Variant
For Each char In KinsokuList
name = Replace(name, char, "", 1, -1, vbTextCompare)
Next

RemoveKinsoku = name
End Function

これを追加しておいて、

NewName = Mid(buff, InStrRev(buff, "\") + 1)
の後に
NewName = RemoveKinsoku(NewName)
NewName = Left(NewName, 31)

としてみましょうか。
まあ全部ひっくるめて

NewName = Left(RemoveKinsoku(Mid(buff, InStrRev(buff, "\") + 1)), 31)

でも良いですが。

※buff の方は実際のフォルダアクセスに使うのでいじらないでおきましょう

補足

何度もありがとうございます。

>うーん? こちらでは問題なく実行できていましたが…

　頭を冷やして
　　回答頂いた内容を読み返しました。

　結果、フォルダーが削除できない原因が判明しました。

　フォルダーが1つしか無い状態で（空のフォルダーも存在しない状態で）
　　同名フォルダー名をターゲットにしてマクロを起動したので
　　シートを削除する事が出来なかったと言うアホな事を繰り返していました。
　　　これは、時が経つと忘れそうなのでエラー処理が必要になるので後で
　　　エラー処理でコメントを出すようにしたいと思います。

(コメントでフォルダーを削除するタイミングに注意するように
　　言われていたのに全く面目ないです。）

------------------------
？？の件ですが、
　　提示いただいた関数及び追加コードを付加してマクロを起動しましたが
　　同じエラーが発生しました。

　　（同じく”ー”の部分（前後の空白らしき部分も含めて）を削除して
　　改めて　半角空白と(-)マイナスで置き換えると問題なく処理できます。）

ターゲットのフォルダーの容量が10GBと多いので
　　マクロ起動中は、カーソルは「待ち状態」のポインターをずっと表示していて
　　エラーが出ても気が付かない状態です。
　　（エラー表示がデスクトップの最上面に出ていないので気が付きにくい）

　　これは、大いに困った状態です。

回答No.8

asciiz

＞以下が参考になりそうですが、私の知識が追いつきません。
＞https://www.petitmonte.com/bbs/answers?question_id=14516

シリアル番号を取得したいならば、Office TANAKA さんの方で言うと

＞Office TANAKA - FileSystemObject[SerialNumberプロパティ]
＞http://officetanaka.net/excel/vba/filesystemobject/drive09.htm

こちらの解説と一緒です。私の提案したVolumeNameプロパティと好きな方でどうぞ。

＞　　　同名のシートがあれば削除して新たに挿入する
＞　でコードを追加してみましたが、上手く処理出来ません。

だいたい良かったですよ。
ただ、新しいシートを作る前から Worksheet オブジェクトで何かしようって所がちょっと勇み足だったと思います。

単に作る予定のシート名を文字列変数に格納して、今あるシート名と比較、そして作るときに利用、で十分だったでしょう。

Sub Test()
Dim buff As String
Dim sh As Object

cnt = 1
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
buff = .SelectedItems(1)
End With

Dim NewName As String
NewName = Mid(buff, InStrRev(buff, "\") + 1)

'同名のシートがあれば削除して新たに挿入する
For Each sh In Worksheets
If sh.Name = NewName Then
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
End If
Next sh

Set NewWorkSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
NewWorkSheet.Name = NewName

Call Sample3(buff)
End Sub

お礼

訂正コードをありがとうございます。

修正コードをコピペして
同名シートが有る状態で同じフォルダーをターゲットにしてマクロを実行すると
以下でエラーが出ました。

sh.Delete

実行エラー　1004
　WorksheetクラスのDeleteメソッドが失敗しました。

------------------------------
HDDの固有番号については、後回しにしたいと思います。

実は、他のフォルダーを試験ターゲットにしてマクロを走らせると
エラーがでるので重要な問題を先に解决すべきと判断しました。

問題は、
VBAでフォルダー名（ファイル名）を読み込む処理をしていますが
　読めない文字列が有るようなのです。

使用できない文字列については、下記のサイトで紹介されていますが、
　　それらとは違う文字（？）又はよく分かりませんが見えない文字（制御文字？）が混入しているようです。
https://excel-ubara.com/excelvba4/EXCEL250.html

エラーは、下記内容です。
　実行エラー 52
　ファイル名または番地が不正です。

添付画像では分かりにくいでしょうが
　　Cusco - Desert の間の "-"が
　　　　Pathにマウスを近づけると　"？？"で
　　　　　表示されています。

この？？が問題なのでしょうが、何者かがよく分かりません。

チェックする方法とかはありますか　？
　例えば、文字コードを調べる方法など。

-------------------
ちなみに
　”ー”の部分（前後の空白らしき部分も含めて）を削除して
　　改めて　半角空白と(-)マイナスで置き換えると問題なく処理できます。

何分見た目では、エラー原因が判断できないし複数あるフォルダーを場当たり的に
　手動で置き換えていくのも手間暇がかかり過ぎます。

添付画像
https://imgur.com/qaxwf6j

回答No.7

asciiz

＞OSのデバイスマネージャー＞ディスクドライブ　の項目で表示されている
＞　認識番号を利用したいと思うのですが
＞　認識番号をHDDから読み出して書き込む方法が分かりません。

んー、認識番号は取得できましたかね—?
それは難しい気がしますが、VBAからは、ドライブの情報として以下にあるものが取得できます。

＞Office TANAKA - FileSystemObject[Driveオブジェクト]
＞http://officetanaka.net/excel/vba/filesystemobject/drive.htm

C: とか J: みたいなドライブ名は、選択フォルダ名 buff の先頭文字でわかりますから、
そのドライブのボリューム名

＞Office TANAKA - FileSystemObject[VolumeNameプロパティ]
＞http://officetanaka.net/excel/vba/filesystemobject/drive12.htm

をつければ良いんじゃないでしょうか。
こちらなら簡単です。

補足

>んー、認識番号は取得できましたかね—?

以下が参考になりそうですが、私の知識が追いつきません。

https://www.petitmonte.com/bbs/answers?question_id=14516

同名のフォルダーがある場合の処理ですが、
　取り得ず取っ掛かりで
　　　同名のシートがあれば削除して新たに挿入する
　でコードを追加してみましたが、上手く処理出来ません。

　アドバイスあればお願いします。

以下現在のコードです。

Sub Test()
Dim buff As String
Dim Dname As String
Dim NewWorkSheet As Worksheet
Dim sh As Object

cnt = 0

With Application.FileDialog(msoFileDialogFolderPicker)
'If .Show = 0 Then
' MsgBox "キャンセルボタンがクリックされました。"
' Exit Sub
'End If
.Show
buff = .SelectedItems(1)
Dname = .InitialFileName
End With

NewWorkSheet.Name = Mid(buff, InStrRev(buff, "\") + 1)

'同名のシートがあれば削除して新たに挿入する
For Each sh In Worksheets
If sh.Name = NewWorkSheet.Name Then
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
End If
Next sh

'Sheets.Add.Name = shname

Set NewWorkSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
NewWorkSheet.Name = Mid(buff, InStrRev(buff, "\") + 1)

Call Sample3(buff)
End Sub

回答No.6

asciiz

＞マクロを行う毎に別のシートに書き出すように処理したいのですが
＞何かスマートな方法はありますか　？

ちょっとした発想の転換ですね
マクロ実行したら毎回新シート作っちゃえば良いでしょう。

＞Office TANAKA - シートの操作[新しいシートを挿入する]
＞http://officetanaka.net/excel/vba/sheet/sheet03.htm

を参考に、Call sample3(buff) の直前に以下を入れてください。

Dim NewWorkSheet As Worksheet
Set NewWorkSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
NewWorkSheet.Name = Mid(buff, InStrRev(buff, "\") + 1)

今あるシート群の最後に新しいシートを追加します。
ついでにシート名にも、選択したフォルダ名つけてます。(C:\aaa\bbb\ccc\ddd から ddd だけ取り出す感じ)

なお毎回増やしてしまうのでシート1枚目が全く使われないことになりますが、適当なタイミングで削除するか、使い方のメモでも書いておくとかに使えるでしょう。

----

ところで、

＞ cnt = cnt + 2

ここは +1 じゃないと、1行おきに入っちゃうような?
意図したものなら良いんですが。

2行目から順番に入れたいなら、上記の部分は +1 にして、変数 cnt の初期化で

cnt = 1

とすれば良いですね。

お礼

asciizさん、引き続きアドバイス感謝します。

ご指摘のとうりcntの増加方法に不備がありました。
　確かに＋2ではダメですね。
　　（A列にヘッダーを追加したので安易に＋2としてしまいました。）

フォルダー名でシートを追加するアイデアのアドバイスありがとうございます。
とても良い提案だと思いますが、運用において以下の問題が有ることが判りました。

シートを追加時に既に同じ名前のシートがある場合は、以下のコードでエラーがでます。

　NewWorkSheet.Name = Mid(buff, InStrRev(buff, "\") + 1)

　　　実行エラー　1004
　　　　　この名前は既に使用されています。別の名前を入力してください。

フォルダー内のファイル（ｍｐ3）で追加（修正）や削除が出た場合は、
　　DATABASEの更新ｎ為同じシート名で上書きする必要が出るので
　　同じシート名が有るが、上書きしても良いか？の判断が必要になってきます。

　　（YESでシート名を追加せずに同じ名前のシートに上書きを許可。
　　　　NOで処理をエラー表示をせずぬ同じシートが合ったので処理を中止すると表示して終了する。）

-----------------
MP3があるデバイスは、ほとんどが外付けのHDDです。
これを判別するために、
　DATABASEの検索時に後々便利なので
　ハードディスクの名称を書き出したいと思います。

　OSのデバイスマネージャー＞ディスクドライブ　の項目で表示されている
　　　認識番号を利用したいと思うのですが
　　　認識番号をHDDから読み出して書き込む方法が分かりません。

　方法があれば教えて下さい。

回答No.5

asciiz

うーん、一文字も変わってないのに何ででしょうね?
とりあえず、

＞ buff = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)

を

With Application.FileDialog(msoFileDialogFolderPicker)
.Show
buff = .SelectedItems(1)
End With

に置き換えることで、通りました。
(フォルダ選択ダイアログが出ないまま次に進んでしまい、SelectedItems に何も入ってないのでエラー5になっていた、ようです。)

補足

ありがとうございます。

コードが変わらないのにエラーが出るのは不思議ですね。
教えてもらったコードに変更してエラーは出なくなりました。

一応、希望の処理はできる様になったのですが
　欲が出てマクロを行う毎に別のシートに書き出すように処理したいのですが
　何かスマートな方法はありますか　？

つまり、マクロを起動して処理するパスを指定したら1つのシートを使用して
　マクロで複数回処理すると同じだけシートに書き出すと言う事です。

-----------------------------

以下が現在のコードです。

Dim cnt As Long

Sub Sample3(Path As String)
Dim buf As String
Dim f As Object
Dim SHell As Variant

Set SHell = CreateObject("Shell.Application")
Dim Folder As Variant
Set Folder = SHell.Namespace(Path & "\")

buf = Dir(Path & "\*.mp3")

Cells(1, 3) = "曲名"
Cells(1, 4) = "パス"
Cells(1, 1) = "アーチスト"
Cells(1, 2) = "アルバム"
Cells(1, 5) = "制作年"
Cells(1, 6) = "ジャンル"

Range("A1:F1").Font.Bold = True

Do While buf <> ""
cnt = cnt + 2

Cells(cnt, 3) = buf '曲名
Cells(cnt, 4) = Path 'パス
Cells(cnt, 1) = Folder.GetDetailsOf(Folder.ParseName(buf), 20) 'アーチスト
Cells(cnt, 2) = Folder.GetDetailsOf(Folder.ParseName(buf), 14) 'アルバム
Cells(cnt, 5) = Folder.GetDetailsOf(Folder.ParseName(buf), 15) '年
Cells(cnt, 6) = Folder.GetDetailsOf(Folder.ParseName(buf), 16) 'ジャンル
buf = Dir()
Loop
With CreateObject("Scripting.FileSystemObject")
For Each f In .GetFolder(Path).SubFolders
Call Sample3(f.Path)
Next f
End With
End Sub

Sub Test()
Dim buff As String

cnt = 0

With Application.FileDialog(msoFileDialogFolderPicker)
.Show
buff = .SelectedItems(1)
End With

'MsgBox buff
Call Sample3(buff)
End Sub

回答No.4

asciiz

＞　　Set Folder = SHell.Namespace(path)
＞ で良いかと思いましたが、

＞ 以下でエラーが発生（実行時エラー'91')でダメでした。
＞ Cells(cnt, 3) = Folder.GetDetailsOf(Folder.ParseName("xxxx.mp3"), 0)

あれれーー?
いやもう、その通りでいいと思うんですが…。

で、こちらでもやってみたところ、

Set Folder = SHell.Namespace(Path & "\")

とすると、通りました。
なんで末尾"\"が必要になるのかは調べてません、とりあえず勘で直してしまいました。

あとこちらの行は、ファイル名を指定して欲しいので
＞ Cells(cnt, 3) = Folder.GetDetailsOf(Folder.ParseName("xxxx.mp3"), 0)
↓
＞ Cells(cnt, 3) = Folder.GetDetailsOf(Folder.ParseName(buf), 0)

にしてみてください。

お礼

コードの修正、ありがとうございます。

コードをアドバイスのように修正して
　作動テストを行って何度かは上手く作動したのですが
　コードを最終的に下記のように修正すると
　なぜだか？エラーが発生するようになってしまいました。

　　（コードの修正順番やコードを修正した場所を正確には記録していません。）

エラーが出るようになった原因は何でしょうか　？

Tag情報は、下記サイトの値を利用しました。
https://www.excellovers.com/entry/2018/04/22/221602

　・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・
buff = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)

　　実行エラー　5
　　　　プロシージャの呼び出し、または引数が不正です。

　（上記コードは、何も修正していないはずです以前はエラーが出なかったのに
　　　なぜだかエラーが出るようになった。）
　・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・

以下は、現在のコードです。

Dim cnt As Long

Sub Sample3(Path As String)
Dim buf As String
Dim f As Object
Dim SHell As Variant

Set SHell = CreateObject("Shell.Application")
Dim Folder As Variant
Set Folder = SHell.Namespace(Path & "\")

buf = Dir(Path & "\*.mp3")
Do While buf <> ""
cnt = cnt + 1
Cells(cnt, 3) = buf '曲名
Cells(cnt, 4) = Path 'パス
Cells(cnt, 1) = Folder.GetDetailsOf(Folder.ParseName(buf), 20) 'アーチスト
Cells(cnt, 2) = Folder.GetDetailsOf(Folder.ParseName(buf), 14) 'アルバム
Cells(cnt, 5) = Folder.GetDetailsOf(Folder.ParseName(buf), 15) '年
Cells(cnt, 6) = Folder.GetDetailsOf(Folder.ParseName(buf), 16) 'ジャンル
buf = Dir()
Loop
With CreateObject("Scripting.FileSystemObject")
For Each f In .GetFolder(Path).SubFolders
Call Sample3(f.Path)
Next f
End With
End Sub

Sub Test()
Dim buff As String

cnt = 0

buff = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
'MsgBox buff
Call Sample3(buff)
End Sub

回答No.3

asciiz

＞TANAKA氏の参考になる記事との整合性が取れずコードが書けません。

Office TANAKA さんの方では、WSHの機能でファイルリストを取り、さらにWSHの機能でファイル情報を取ってきているわけですね。

指定のファイル1つだけに関して情報を得る部分を取り出すと、例えば次のようになります。

Sub test2()
Dim SHell As Variant
Set SHell = CreateObject("Shell.Application")
Dim Folder As Variant
Set Folder = SHell.Namespace("J:\#Song_t")
Cells(1, 1) = Folder.GetDetailsOf(Folder.ParseName("xxxx.mp3"), 0)
Cells(1, 2) = Folder.GetDetailsOf(Folder.ParseName("xxxx.mp3"), 21)
End Sub

一方、mougさん速攻テクニックの方では、フォルダ名を指定して、Dir関数でファイル名までは取れています。

なので、mp3ファイルの情報をもらうとこだけ Office TANAKA さんの方でやればよいでしょう。

SHell オブジェクトは全体で1度だけ定義すれば良い、Folder オブジェクトはフォルダごとに必要、となると、プログラムのどこに挿入すれば良いでしょうか。
やってみてください。

補足

アドバイスありがとうございます。

私なりの理解では、
　　buffにフォルダー名を取得しているので

　　Set Folder = SHell.Namespace("J:\#Song_t")
を　　
　　Set Folder = SHell.Namespace(path)
で良いかと思いましたが、

以下でエラーが発生（実行時エラー'91')でダメでした。
Cells(cnt, 3) = Folder.GetDetailsOf(Folder.ParseName("xxxx.mp3"), 0)

もう少しヒントをいただけませんか　？

以下は、現在のコードです。

---------------------------------------

Dim cnt As Long

Sub Sample3(Path As String)
Dim buf As String
Dim f As Object
Dim SHell As Variant

Set SHell = CreateObject("Shell.Application")
Dim Folder As Variant
Set Folder = SHell.Namespace(Path)

buf = Dir(Path & "\*.mp3")
Do While buf <> ""
cnt = cnt + 1
Cells(cnt, 1) = buf
Cells(cnt, 2) = Path
Cells(cnt, 3) = Folder.GetDetailsOf(Folder.ParseName("xxxx.mp3"), 0)
Cells(cnt, 4) = Folder.GetDetailsOf(Folder.ParseName("xxxx.mp3"), 21)
buf = Dir()
Loop
With CreateObject("Scripting.FileSystemObject")
For Each f In .GetFolder(Path).SubFolders
Call Sample3(f.Path)
Next f
End With
End Sub

Sub Test()
Dim buff As String

cnt = 0

buff = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
'MsgBox buff
Call Sample3(buff)
End Sub

回答No.2

asciiz

＞フルパス名を表示するようにするにはどうしたら良いでしょうか？

Sample3() が呼び出された時、変数 Path にその階層のパス名が入っているのですから、
Cells(cnt, 1) = buf
を
Cells(cnt, 1) = Path & "\" & buf
にすればフルパスで入ることになります。

あるいは、
Cells(cnt, 1) = Path
Cells(cnt, 2) = buf
と分けて入れといたほうが便利な場合もあるかもしれませんね。
都合の良い方でどうぞ。

お礼

asciizさん、追加のアドバイスありがとうございます。

おかげさまでフルパスをセルに書き出せました。
ついでに、ダイアログを表示してターゲットのディレクトリーを指定できるようにしました。

後残っている処理は、
　　タグ情報をファイル（MP3）から読み出してセルに書き出す処理ですが
　　能力不足でTANAKA氏の参考になる記事との整合性が取れず
　　コードが書けません。

　　コードをどのようにすれば良いか教えて下さい。

以下は、現在のコード
---------------------------------------------

Dim cnt As Long

Sub Sample3(Path As String)
Dim buf As String
Dim f As Object

buf = Dir(Path & "\*.mp3")
Do While buf <> ""
cnt = cnt + 1
Cells(cnt, 1) = buf
Cells(cnt, 2) = Path
buf = Dir()
Loop
With CreateObject("Scripting.FileSystemObject")
For Each f In .GetFolder(Path).SubFolders
Call Sample3(f.Path)
Next f
End With
End Sub

Sub Test()
Dim buff As String

cnt = 0

buff = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
Call Sample3(buff)

回答No.1

asciiz

こちらの様に、カレントディレクトリのリストを得るDir関数を、「再起呼び出しするように」組みます。
(再起じゃない書き方もできますが、フォルダ探索は再起で書いた方が自然なように思います)

＞VBA フォルダー階層を辿るサンプル ～ 再帰をマスターする - t-hom’s diary
＞https://thom.hateblo.jp/entry/2016/01/10/025636
＞サブフォルダを含めてファイル一覧を取得する（Dir関数の再帰呼び出し）：Excel VBA｜即効テクニック｜Excel VBAを学ぶならmoug
＞https://www.moug.net/tech/exvba/0060088.html

お礼

asciizさん、ありがとうございます。

教えてもらったサイトのコードを利用させてもらいました。

全て希望を解决するのは難しいので
　1つずつ解決する事にして

まず、Dir()では、ファイル名は表示されますが
　フルパス名は表示されません。

フルパス名を表示するようにするにはどうしたら良いでしょうか　？

Dim cnt As Long

Sub Sample3(Path As String)
　　Dim buf As String, f As Object
　　buf = Dir(Path & "\*.mp3")
　　Do While buf <> ""
　　　　cnt = cnt + 1
　　　　Cells(cnt, 1) = buf
　　　　buf = Dir()
　　Loop
　　With CreateObject("Scripting.FileSystemObject")
　　　　For Each f In .GetFolder(Path).SubFolders
　　　　　　Call Sample3(f.Path)
　　　　Next f
　　End With
End Sub

Sub Test()
　　cnt = 0
　　Call Sample3("J:\#Song_t")
End Sub