つらつら Excel VBA

私の備忘録です。

フォルダを開く

Excel VBA

どれもフォルダを開く処理。エラー処理を忘れないこと。

ThisWorkbook.FollowHyperlink folderPath

CreateObject("WScript.Shell").Run folderPath

shell "explorer " & folderPath, vbNormalFocus

' ファイルを選択した状態でフォルダを開く。フルパスであることに注意。
shell "explorer /select, " & fullPath, vbNormalFocus


フルパスからフォルダパスを取得する１例。

Sub フォルダパスを取得する()
    
    Dim fullPath As String
    fullPath = ThisWorkbook.FullName 'テスト用
    
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Dim folderPath As String
    folderPath = FSO.getParentFolderName(fullPath)
    
    'shell "explorer " & folderPath, vbNormalFocus ' フォルダを開く
    
End Sub


フォルダ有無の確認用。

If Dir(folderPath, vbDirectory) = "" Then
    ' フォルダが存在しない
Else
    ' OK
End If


If fso.FolderExists(folderPath) = True Then
    'OK
Else
    'フォルダが存在しない
End If


以上。

ファイルのプロパティ取得

Excel VBA

GetDetailsOf。作成日付や更新日付、アルバムやアーティスト、ビットレート等々のプロパティ情報を取得する。

'参照設定
'Microsoft Shell Controls And Automation

Sub プロパティ取得()
    
    Dim fso As Object, file As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Set file = fso.GetFile(ThisWorkbook.FullName) '対象ファイルを指定
    
    Dim shell, folder
    Set shell = New Shell32.shell
    Set folder = shell.Namespace(file.ParentFolder.Path)
    
    Cells.Clear
    
    Dim i As Long
    For i = 0 To 500
        Cells(i + 1, 1).Value = i
        Cells(i + 1, 2).Value = folder.GetDetailsOf("", i) 'プロパティ名
        Cells(i + 1, 3).Value = folder.GetDetailsOf(folder.ParseName(file.Name), i) '内容
    Next
    
    Set folder = Nothing
    Set shell = Nothing
    
End Sub


プロパティ名を取得する箇所はNothingでも可。

= folder.GetDetailsOf("", i) 'プロパティ名
= folder.GetDetailsOf(Nothing, i) 'プロパティ名


OSやバージョンによって実行結果が違うので注意！
自分の環境の実行結果をそのまま載せておきますが、あてにしないこと。

Win7プロパティ名Win10プロパティ名
0名前0名前
1サイズ1サイズ
2項目の種類2項目の種類
3更新日時3更新日時
4作成日時4作成日時
5アクセス日時5アクセス日時
6属性6属性
7オフラインの状態7オフラインの状態
8オフラインで利用可能8利用可能性
9認識された種類9認識された種類
10所有者10所有者
11分類11分類
12撮影日時12撮影日時
13参加アーティスト13参加アーティスト
14アルバム14アルバム
15年15年
16ジャンル16ジャンル
17指揮者17指揮者
18タグ18タグ
19評価19評価
20作成者20作成者
21タイトル21タイトル
22件名22件名
23分類項目23分類項目
24コメント24コメント
25著作権25著作権
26トラック番号26トラック番号
27長さ27長さ
28ビット レート28ビット レート
29保護29保護
30カメラのモデル30カメラのモデル
31大きさ31大きさ
32カメラの製造元32カメラの製造元
33会社33会社
34ファイルの説明34ファイルの説明
35プログラム名35マスター キーワード
36継続時間36マスター キーワード
37オンライン37
38再帰38
39場所39
40任意出席者アドレス40
41任意出席者41
42開催者住所42プログラム名
43開催者名43継続時間
44アラーム時刻44オンライン
45必須出席者アドレス45再帰
46必須出席者46場所
47リソース47任意出席者アドレス
48会議の状態48任意出席者
49空き時間情報49開催者住所
50合計サイズ50開催者名
51アカウント名51アラーム時刻
52進捗状況52必須出席者アドレス
53コンピューター53必須出席者
54記念日54リソース
55秘書の名前55会議の状態
56秘書の電話56空き時間情報
57誕生日57合計サイズ
58住所 (会社)58アカウント名
59市 (会社)59
60国/地域 (会社)60進捗状況
61私書箱 (会社)61コンピューター
62郵便番号 (会社)62記念日
63都道府県 (会社)63秘書の名前
64番地 (会社)64秘書の電話
65FAX 番号 (会社)65誕生日
66会社のホーム ページ66住所 (会社)
67会社電話67市 (会社)
68コールバック番号68国/地域 (会社)
69自動車電話69私書箱 (会社)
70子供70郵便番号 (会社)
71会社代表電話71都道府県 (会社)
72部署72番地 (会社)
73電子メール アドレス73FAX 番号 (会社)
74電子メール274会社のホーム ページ
75電子メール375会社電話
76電子メールの一覧76コールバック番号
77電子メール表示名77自動車電話
78表題278子供
79名79会社代表電話
80氏名80部署
81性別81電子メール アドレス
82名282電子メール2
83趣味83電子メール3
84住所 (自宅)84電子メールの一覧
85市 (自宅)85電子メール表示名
86国/地域 (自宅)86表題2
87私書箱 (自宅)87名
88郵便番号 (自宅)88氏名
89都道府県 (自宅)89性別
90番地 (自宅)90名2
91自宅 FAX91趣味
92自宅電話92住所 (自宅)
93IM アドレス93市 (自宅)
94イニシャル94国/地域 (自宅)
95役職95私書箱 (自宅)
96ラベル96郵便番号 (自宅)
97姓97都道府県 (自宅)
98住所 (郵送先)98番地 (自宅)
99ミドル ネーム99自宅 FAX
100携帯電話100自宅電話
101ニックネーム101IM アドレス
102勤務先所在地102イニシャル
103住所 (その他)103役職
104ほかの市区町村104ラベル
105他の国/地域105姓
106他の私書箱106住所 (郵送先)
107他の郵便番号107ミドル ネーム
108他の都道府県108携帯電話
109他の番地109ニックネーム
110ポケットベル110勤務先所在地
111肩書き111住所 (その他)
112市区町村 (郵送先)112ほかの市区町村
113国/地域113他の国/地域
114私書箱 (郵送先)114他の私書箱
115郵便番号 (郵送先)115他の郵便番号
116都道府県116他の都道府県
117番地 (郵送先)117他の番地
118プライマリ電子メール118ポケットベル
119通常の電話119肩書き
120職業120市区町村 (郵送先)
121配偶者121国/地域
122サフィックス122私書箱 (郵送先)
123TTY/TTD 電話123郵便番号 (郵送先)
124テレックス124都道府県
125Web ページ125番地 (郵送先)
126内容の状態126プライマリ電子メール
127内容の種類127通常の電話
128取得日時128職業
129アーカイブ日時129配偶者
130完了日130サフィックス
131デバイス カテゴリ131TTY/TTD 電話
132接続済み132テレックス
133探索方法133Web ページ
134フレンドリ名134内容の状態
135ローカル コンピューター135内容の種類
136製造元136取得日時
137モデル137アーカイブ日時
138ペアリング済み138完了日
139クラス139デバイス カテゴリ
140状態140接続済み
141クライアント ID141探索方法
142貢献者142フレンドリ名
143コンテンツの作成日時143ローカル コンピューター
144前回印刷日144製造元
145前回保存日時145モデル
146事業部146ペアリング済み
147ドキュメント ID147クラス
148ページ数148状態
149スライド149状態
150総編集時間150クライアント ID
151単語数151共同作成者
152期限152コンテンツの作成日時
153終了日153前回印刷日
154ファイル数154前回保存日時
155ファイル名155事業部
156ファイル バージョン156ドキュメント ID
157フラグの色157ページ数
158フラグの状態158スライド
159空き領域159総編集時間
160ビットの深さ160単語数
161水平方向の解像度161期限
162幅162終了日
163垂直方向の解像度163ファイル数
164高さ164ファイル拡張子
165重要度165ファイル名
166添付166ファイル バージョン
167削除167フラグの色
168暗号化の状態168フラグの状態
169フラグの有無169空き領域
170終了済170
171未完了171
172開封の状態172グループ
173共有173共有の種類
174製作者174ビットの深さ
175日付時刻175水平方向の解像度
176フォルダー名176幅
177フォルダーのパス177垂直方向の解像度
178フォルダー178高さ
179参加者179重要度
180パス180添付
181場所ごと181削除
182種類182暗号化の状態
183連絡先の名183フラグの有無
184履歴の種類184終了済
185言語185未完了
186最終表示日186開封の状態
187説明187共有
188リンクの状態188製作者
189リンク先189日付時刻
190URL190フォルダー名
191メディアの作成日時191フォルダーのパス
192リリース日192フォルダー
193エンコード方式193参加者
194プロデューサー194パス
195発行元195場所ごと
196サブタイトル196種類
197ユーザー Web URL197連絡先の名
198作者198履歴の種類
199添付ファイル199言語
200BCC アドレス200最終表示日
201BCC201説明
202CC アドレス202リンクの状態
203CC203リンク先
204会話 ID204URL
205受信日時205
206送信日時206
207送信元アドレス207
208差出人208メディアの作成日時
209添付ファイルの有無209リリース日
210送信者アドレス210エンコード方式
211送信者名211エピソード番号
212ストア212プロデューサー
213送信先アドレス213発行元
214To do タイトル214シーズン番号
215宛先215サブタイトル
216経費情報216ユーザー Web URL
217アルバムのアーティスト217作者
218アルバム ID218
219ビート数/分219添付ファイル
220作曲者220BCC アドレス
221イニシャル キー221BCC
222コンパイルの一部222CC アドレス
223雰囲気223CC
224セットのパート224会話 ID
225期間225受信日時
226色226送信日時
227保護者による制限227送信元アドレス
228保護者による制限の理由228差出人
229使用領域229添付ファイルの有無
230EXIF バージョン230送信者アドレス
231イベント231送信者名
232露出補正232ストア
233露出プログラム233送信先アドレス
234露出時間234To do タイトル
235絞り値235宛先
236フラッシュ モード236経費情報
237焦点距離237アルバムのアーティスト
23835mm 焦点距離238アルバム アーティストで並べ替え
239ISO 速度239アルバム ID
240レンズ メーカー240アルバムで並べ替え
241レンズ モデル241参加アーティストで並べ替え
242光源242ビート数/分
243最大絞り243作曲者
244測光モード244作曲者で並べ替え
245向き245ディスク
246人物246イニシャル キー
247プログラムのモード247コンパイルの一部
248彩度248雰囲気
249対象の距離249セットのパート
250ホワイト バランス250期間
251優先度251色
252プロジェクト252保護者による制限
253チャンネル番号253保護者による制限の理由
254この回のタイトル254使用領域
255字幕255EXIF バージョン
256再放映256イベント
257SAP257露出補正
258放送日258露出プログラム
259プログラムの説明259露出時間
260記録時間260絞り値
261ステーション コール サイン261フラッシュ モード
262局名262焦点距離
263概要26335mm 焦点距離
264抜粋264ISO 速度
265自動要約265レンズ メーカー
266検索のランキング266レンズ モデル
267秘密度267光源
268共有ユーザー268最大絞り
269共有状態269測光モード
270製品名270向き
271製品バージョン271人物
272サポートのリンク272プログラムのモード
273ソース273彩度
274開始日274対象の距離
275課金情報275ホワイト バランス
276完了276優先度
277仕事の所有者277プロジェクト
278総ファイル サイズ278チャンネル番号
279商標279この回のタイトル
280ビデオ圧縮280字幕
281ディレクター281再放映
282データ速度282SAP
283フレーム高283放送日
284フレーム率284プログラムの説明
285フレーム幅285記録時間
286総ビット レート286ステーション コール サイン
287287局名
288288概要
289289抜粋
290290自動要約
291291関連度
292292ファイルの所有権
293293秘密度
294294共有ユーザー
295295共有状態
296296
297297製品名
298298製品バージョン
299299サポートのリンク
300300ソース
301301開始日
302302共有中
303303可用性の状態
304304状態
305305課金情報
306306完了
307307仕事の所有者
308308タイトルで並べ替え
309309総ファイル サイズ
310310商標
311311ビデオ圧縮
312312ディレクター
313313データ速度
314314フレーム高
315315フレーム率
316316フレーム幅
317317球形
318318ステレオ
319319ビデオの向き
320320総ビット レート

以上。

ベームベーム

Excel VBA 三角関数 オートシェイプ


円と弧円の組み合わせで描く。

魔方陣や放射状の線、幾何学模様は中心を決めて描くとキレイ。


円を描く

中心と半径を決めてオートシェイプを作る。

Option Explicit

'線のデフォルトカラーと太さ。
Const LINE_BOLD As Long = 5
Const LINE_COLOR As Long = vbBlue

'オートシェイプ円の作成。
'円の中心と半径からオートシェイプの作成位置を計算。
Function makeShapeOval(ws As Worksheet, sX, sY, iRadius, _
                        Optional iLineColor As Long = LINE_COLOR, _
                        Optional iLineBold As Long = LINE_BOLD) As Shape
    
    Dim x As Double: x = sX - iRadius '円の開始位置
    Dim y As Double: y = sY - iRadius '円の開始位置
    Dim iDiameter As Double: iDiameter = iRadius * 2 '直径
    
    Dim myShape As Shape
    Set myShape = ws.Shapes.AddShape(msoShapeOval, x, y, iDiameter, iDiameter)
    
    With myShape
        .Line.Weight = iLineBold
        .Line.ForeColor.RGB = iLineColor '外枠
        .Fill.Visible = msoFalse '塗りつぶし無し
        '.Fill.ForeColor.RGB = iForeColor '塗りつぶし色
    End With
    
    Set makeShapeOval = myShape
    
End Function

'オートシェイプ直線の作成。ついでに作った。
Function makeShapeLine(ws As Worksheet, sX, sY, eX, eY, _
                        Optional iForeColor As Long = LINE_COLOR, _
                        Optional iLineBold As Long = LINE_BOLD) As Shape
    
    Dim myShape As Shape
    Set myShape = ws.Shapes.AddLine(sX, sY, eX, eY)
    
    With myShape.Line
        .Weight = iLineBold
        .ForeColor.RGB = iForeColor
    End With
    
    Set makeShapeLine = myShape
    
End Function


円状にオートシェイプを配置

円の大きさを決めて、円弧部分の座標を計算する練習。
幾何学模様を作るのに、そのまま使える。

'X座標計算用。
Function Coord_X(deg As Integer) As Double
    Dim pi As Double, dx As Double
    pi = WorksheetFunction.pi() '円周率
    dx = Cos(deg * pi / 180)
    Coord_X = dx
End Function

'Y座標計算用。
Function Coord_Y(deg As Integer) As Double
    Dim pi As Double, dy As Double
    pi = WorksheetFunction.pi() '円周率
    dy = Sin(deg * pi / 180)
    Coord_Y = dy
End Function

Sub テスト_放射状に線を描く()
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("テスト")
    
    '中心点を決める
    Dim iCenterLeft As Integer
    Dim iCenterTop As Integer
    iCenterLeft = Range("D12").Left
    iCenterTop = Range("D12").Top
    
    Dim 始点x As Double, 始点y As Double
    Dim 終点x As Double, 終点y As Double
    
    Dim i As Integer
    For i = 0 To 359 Step 3 '度
        始点x = Coord_X(i) * 0 + iCenterLeft
        始点y = Coord_Y(i) * 0 + iCenterTop
        終点x = Coord_X(i) * 100 + iCenterLeft
        終点y = Coord_Y(i) * 100 + iCenterTop
        Call makeShapeLine(ws, 始点x, 始点y, 終点x, 終点y)
    Next
    
End Sub

上記プログラムのベタ打ち値を変えればいろいろ作れる。楕円ぽい形も作れる。


扇形を作る

中心位置と半径、中心角と回転（角度の開始と終了）を決める。
扇形ぽく点を配置して、点と点を直線か曲線で結ぶ。
弧円部分は曲線で結び、弧円の終端と中心角は直線で結ぶ。
やることが多い。

'座標格納用。
Type dot
    x As Double
    y As Double
End Type

'フリーフォーマット形式で扇形のオートシェイプを作成する。
Function makeSector(ws As Worksheet, iCenterLeft, iCenterTop, iRadius, sAngle, eAngle, _
                Optional blnSector As Boolean = False, _
                Optional iForeColor As Long = LINE_COLOR, _
                Optional iLineBold As Long = LINE_BOLD) As Shape
    
    Dim myShape As Shape
    Dim ffb As FreeformBuilder
    
    Dim dx As Double, dy As Double
    Dim dotList() As dot
    Dim iDotCount As Integer
    
    Dim angle As Integer
    Dim apex As Integer
    
    apex = 15 '頂点の数のテスト値。
    
    Dim i As Integer
    For i = 0 To apex
        
        angle = i * (eAngle - sAngle) / apex
        dx = iCenterLeft + Coord_X(sAngle + angle - 90) * iRadius '-90で上を開始位置に調整
        dy = iCenterTop + Coord_Y(sAngle + angle - 90) * iRadius '同様
        
        iDotCount = iDotCount + 1
        ReDim Preserve dotList(1 To iDotCount)
        dotList(iDotCount).x = dx
        dotList(iDotCount).y = dy
        
    Next
    
    '取得した点を曲線で繋げる。
    For i = LBound(dotList) To UBound(dotList)
        
        dx = dotList(i).x
        dy = dotList(i).y
        
        Select Case i
        
        Case LBound(dotList)
            Set ffb = ws.Shapes.BuildFreeform(msoEditingAuto, dx, dy)
            
        Case LBound(dotList) + 1, UBound(dotList), UBound(dotList) - 1
            '最初と最後だけ直線で繋ぐと違和感少なめ。
            ffb.AddNodes msoSegmentLine, msoEditingAuto, dx, dy
            
        Case Else
            ffb.AddNodes msoSegmentCurve, msoEditingAuto, dx, dy
            
        End Select
        
    Next
    
    '扇形の直線部分は円弧の先端と円の中心を最後に繋ぐ。
    If blnSector Then
        ffb.AddNodes msoSegmentLine, msoEditingAuto, iCenterLeft, iCenterTop
        i = LBound(dotList)
        dx = dotList(i).x
        dy = dotList(i).y
        ffb.AddNodes msoSegmentLine, msoEditingAuto, dx, dy
    End If
    
    Set myShape = ffb.ConvertToShape '作成
    
    With myShape.Line '線
        .DashStyle = msoLineSolid '実線
        .Weight = iLineBold
        .ForeColor.RGB = iForeColor
    End With
    
    With myShape.Fill '塗りつぶし
        .Visible = msoFalse '無し
        '.ForeColor.RGB = iForeColor
    End With
    
    Set makeSector = myShape
    
End Function


その他、必要なヤツ

'ランダム名取得。オートシェイプに任意の名前を付けたい。
'エクセルがオートシェイプの名前を自動的に割り振ってくれるので実は要らない。
Function RandomName() As String
    With CreateObject("Scripting.FileSystemObject")
        RandomName = Replace(.GetTempName, ".tmp", "")
    End With
End Function

'描画部品の名前を保管。グループ化で使う。
'配列を1つ増やして追加する。
Sub ShapeNameArray(arr, s)
    On Error GoTo add1
    Dim i As Integer: i = 0
    i = UBound(arr)
add1:
    i = i + 1
    ReDim Preserve arr(1 To i)
    arr(i) = s
End Sub


各部品の配置場所を計算して設置


円弧の配置場所を計算する。
・正方形の対角線の比率は1:1:√2。
・外側の円の半径を1とした時、円弧の半径の比率は√2。
・円弧の中心位置は外側の円上の4か所、90度刻み。

中央の小さい円は、円弧の半径-外側の円の半径で求まる。

上記を計算しながらオートシェイプを配置。

Sub ベームベーム()
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("テスト")
    
    Dim centerCell As Range
    Dim coreDot As dot '中心点
    Dim outDot As dot '外周上の点を格納
    Dim myShape As Shape
    Dim arrName() As String
    
    Dim mainCircleSize  As Double: mainCircleSize = 100
    Dim tempCircleSize As Double: tempCircleSize = 0
    
    Set centerCell = Range("D10")
    coreDot.x = centerCell.Left
    coreDot.y = centerCell.Top
    Set myShape = makeShapeOval(ws, coreDot.x, coreDot.y, mainCircleSize, rgbBlue)
    myShape.Name = "外周1"
    Call ShapeNameArray(arrName, myShape.Name)
    
    '外周の円サイズを計算
    outDot.x = coreDot.x + Coord_X(0) * mainCircleSize
    tempCircleSize = (outDot.x - coreDot.x) * Sqr(2) '1:1:√2
    
    Dim i As Integer
    For i = 0 To 359 Step 90 '度
        outDot.x = coreDot.x + Coord_X(i) * mainCircleSize '外周の点を取得
        outDot.y = coreDot.y + Coord_Y(i) * mainCircleSize '外周の点を取得
        Set myShape = makeSector(ws, outDot.x, outDot.y, tempCircleSize, i - 45 - 90, i + 45 - 90, False)
        Call ShapeNameArray(arrName, myShape.Name)
    Next
    
    Set myShape = makeShapeOval(ws, coreDot.x, coreDot.y, tempCircleSize - mainCircleSize, rgbBlue)
    myShape.Name = "内周1"
    Call ShapeNameArray(arrName, myShape.Name)
    
    ws.Shapes.Range(arrName).Group.Name = "ベームベーム1"
    
End Sub

作った後は普通のオートシェイプと同様に線の色や太さ、点線変更できる。


以下はstep値だけ変えたもので、左から80度、60度、10度。

以上。

Choose関数

Excel VBA 関数

CHOOSE(インデックス、値1、値2、、、)

インデックスは整数で1から指定する。指定した～番目の値が返る。
Excel2003では29個、Excel2007以降では254個まで。

値部分にSUMとか式を入れ込んだりして複雑なものが作れる。

'エクセル数式
=CHOOSE(4, "A", "B", "C", "D") 'D

'VBA
Debug.Print Choose(1, "AA", "BB", "CC", "DD") 'AA

以上。

mp3バイナリ解析

Excel VBA ファイル処理

mp3タグが文字化けしないよう、文字コードが調べたかった。
最初の3バイトが「ID3」で21バイト目が「01」ならOK！とやるだけでよかった。
それだけでよかったのに、、、

なんか長いのが出来た。
独学なので勘弁。


Option Explicit

Sub メイン処理()
    
    Dim mp3b As classBinaryID3V2
    Dim fileList() As String
    Dim iRow As Long
    Dim tmp As String
    
    Cells.ClearContents
    
    'このエクセルファイルが置かれたフォルダが対象
    Call makeFileList(ThisWorkbook.Path, True, fileList)
    
    Dim i As Long
    For i = LBound(fileList) To UBound(fileList)
        
        If Right(fileList(i), 4) <> ".mp3" Then GoTo fileSkip
        
        Set mp3b = New classBinaryID3V2
        With mp3b
            
            Cells(i, 1).Value = fileList(i)
            
            '先頭10バイトだけ読み込む。
            .SetHexList = readBinary(fileList(i), 10)
            
            'v2.3とv2.4以外を弾く。
            Dim strErrMsg As String: strErrMsg = .checkID3v2
            If Len(strErrMsg) > 0 Then
                Cells(i, 2).Value = strErrMsg: GoTo fileSkip
            End If
            
            'ヘッダーとフレームを全部読み込む。
            .SetHexList = readBinary(fileList(i), .GetAllFrameSize + 10)
            
            .NextFrame '最初のフレームをセット。
            
            Do While .GetFrameID <> ""
                
                '文字コードチェック
                'タイトル、アーティスト、アルバムを確認
                Select Case .GetFrameID
                Case "TIT2", "TPE1", "TALB"
                    tmp = .GetFrameCharacterCode
                    Cells(i, 2).Value = Choose(Int(tmp) + 1, "ISO-8859-1", "UTF-16", "UTF-16", "UTF-8")
                End Select
                
                'タグ情報出力。
                Select Case .GetFrameID
                Case "TIT2" 'タイトル
                    Cells(i, 3).Value = .GetFrameValue
                Case "TPE1" 'アーティスト
                    Cells(i, 4).Value = .GetFrameValue
                Case "TALB" 'アルバム
                    Cells(i, 5).Value = .GetFrameValue
                Case "TRCK" 'トラック
                    Cells(i, 6).Value = .GetFrameValue
                Case "TCON" 'ジャンル
                    Cells(i, 7).Value = .GetFrameValue
                Case "COMM" 'コメント
                    Cells(i, 8).Value = .GetFrameValue
                Case Else

                End Select
                
                .NextFrame '次のフレームを読み込む。
                
            Loop
            
        End With
fileSkip:
        Set mp3b = Nothing
        
    Next
    
    'カラム名後付け
    Rows(1).Insert
    Range("A1:H1").Value = Array("フルパス", "メモ", "タイトル", "アーティスト", "アルバム", "トラック", "ジャンル", "コメント")
    
End Sub


標準モジュールに追加

Option Explicit

'16進数を10進数に変換
Function HexToDec(sHex As String) As Long
    
    HexToDec = BinToDec(HexToBin(sHex))
    
End Function


'2進数を10進数に変換
Function BinToDec(sBin As String) As Long
    
    Dim tmp As String
    tmp = StrReverse(sBin) '文字を逆にする
    
    Dim iSum As Long: iSum = 0
    Dim i As Long
    For i = 1 To Len(tmp)
        If Mid(tmp, i, 1) = "1" Then
            iSum = iSum + 2 ^ (i - 1)
        End If
    Next
    
    BinToDec = iSum
    
End Function


'Syncsafe Integerを計算。16進数を10進数で返却。
'最上位8ビット目をスキップして連結
Function HexToSyncsafeInteger(sHex As String) As Long
    
    Dim rtnStr As String: rtnStr = ""
    
    Dim tmp As String
    tmp = HexToBin(sHex) '16進数を2進数に変換
    tmp = StrReverse(tmp) '文字を逆にする
    
    '最上位8ビット目をスキップして連結
    Dim i As Long
    For i = 1 To Len(tmp)
        If i Mod 8 <> 0 Then rtnStr = Mid(tmp, i, 1) & rtnStr
    Next
    
    HexToSyncsafeInteger = BinToDec(rtnStr)
    
End Function


'16進数を2進数に変換(マイナスとか色々考慮してません)
Function HexToBin(sHex As String) As String
    
    Dim rtnStr As String: rtnStr = ""
    
    Dim tmp As String
    Dim i As Long
    For i = Len(sHex) To 1 Step -1
        tmp = WorksheetFunction.Hex2Bin(Mid(sHex, i, 1))
        tmp = Right("000" & tmp, 4) '桁埋め
        rtnStr = tmp & rtnStr
    Next
    
    HexToBin = rtnStr
    
End Function

Sub 単体チェック用()
    
    Dim filePath As String
    filePath = "C:\音楽\〇〇〇.mp3"
    
    Call getMp3Info(filePath)
    
End Sub


'単体チェック用
Function getMp3Info(filePath As String) As Boolean
    
    Dim iFrameCnt As Long: iFrameCnt = 0
    
    Dim mp3b As classBinaryID3V2
    Set mp3b = New classBinaryID3V2
    
    With mp3b
        
        '先頭10バイトだけ読み込む。
        .SetHexList = readBinary(filePath, 10)
        
        'v2.3とv2.4以外を弾く。
        Dim strErrMsg As String: strErrMsg = .checkID3v2
        If Len(strErrMsg) > 0 Then Debug.Print strErrMsg: GoTo readEnd
        
        'ヘッダー部分を全部読み込む。
        .SetHexList = readBinary(filePath, .GetAllFrameSize + 10)
        
        Debug.Print .GetAllTagBinary
        Debug.Print "----------------------------------------"
        Debug.Print .GetHeaderBinary(" ")
        Debug.Print .GetHeaderID, .GetVersion, .GetAllFrameSize
        
        .NextFrame '次のフレーム（最初）
        
        Do While .GetFrameID <> ""
            
            Debug.Print "----------------------------------------"
            
            iFrameCnt = iFrameCnt + 1
            If iFrameCnt > 20 Then Exit Do '安全装置。タグが20個以上あるならコメントアウト。
            
            Debug.Print .GetFrameBinary(" ")
            Debug.Print .GetFrameID, .GetFrameNameJP, .GetFrameSize, .GetFrameValue
            
            .NextFrame '次のフレーム
            
        Loop
        
    End With
    
readEnd:
    Set mp3b = Nothing
    
End Function

'ファイルをバイナリ形式で読み出す。オプションでバイトサイズ指定。
Function readBinary(filePath As String, Optional readNumByte As Long = 0) As String()
    
    'ファイルサイズが0バイトは終了
    Dim iFileLen As Long
    iFileLen = FileLen(filePath)
    If iFileLen = 0 Then End
    
    Dim iFileNo As Integer
    iFileNo = FreeFile
    
    On Error GoTo OpenErr
    Open filePath For Binary As #iFileNo
    
    Dim bData() As Byte
    
    If readNumByte = 0 Then
        ReDim bData(1 To iFileLen) '全て読み込む
    Else
        ReDim bData(1 To readNumByte)
    End If
    
    Get #iFileNo, , bData
    Close #iFileNo
    
    '読み込んだデータの整形
    Dim sHex() As String
    ReDim sHex(LBound(bData) To UBound(bData))
    
    Dim i As Long
    For i = LBound(bData) To UBound(bData)
        sHex(i) = Right("0" & Hex(bData(i)), 2)
    Next
    
OpenErr:
    readBinary = sHex
    
End Function


'ファイルを検索してファイルリストを返却。
Sub makeFileList(sFolderPath As String, subFolderSearch As Boolean, ByRef fileList() As String)
    
    Dim fso As Object
    Dim folder As Object
    Dim subfolder As Object
    Dim file As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(sFolderPath)
    
    'サブフォルダが無ければループに入らず次へ
    If subFolderSearch Then
        For Each subfolder In folder.SubFolders
            Call makeFileList(subfolder.Path, subFolderSearch, fileList)
        Next subfolder
    End If
    
    For Each file In folder.files
        'Debug.Print file.Name, file.Path, file.Size
        Call addArrayString(fileList, file.Path)
    Next file
    
    Set subfolder = Nothing
    Set folder = Nothing
    Set fso = Nothing
    
End Sub

'配列を1つ増やして追加する。
Private Sub addArrayString(ByRef arr, s)
    On Error GoTo add1
    Dim i As Long: i = 0
    i = UBound(arr) '配列でない場合にエラー
add1:
    i = i + 1
    ReDim Preserve arr(1 To i)
    arr(i) = s
End Sub


classBinaryID3V2クラスを作成

Option Explicit

Private sHex() As String 'バイナリ
Private Location As Long 'フレームの開始位置
Public FrameCount As Long 'フレーム数

'主要タグ
Public TagTitle As String
Public TagArtist As String
Public TagAlbum As String
Public TagTrackNo As String
Public TagGenre As String
Public TagComment As String

'コンストラクタ
Private Sub Class_Initialize()
    Location = 1
    FrameCount = 0
    TagTitle = ""
    TagArtist = ""
    TagAlbum = ""
    TagTrackNo = ""
    TagGenre = ""
    TagComment = ""
End Sub


'バイナリを読み込む。
Public Property Let SetHexList(sHexList() As String)
    sHex = sHexList
End Property


'全てのフレームを巡回し、主要タグのテキストを取得する｡
Public Sub AllTagRead()
    
    Dim backupLocation As Long
    backupLocation = Location
    
    FrameCount = 0
    Location = 1
    NextFrame
    
    Do While GetFrameID <> ""
        
        FrameCount = FrameCount + 1
        
        Select Case GetFrameID
        Case "TIT2" 'タイトル
            TagTitle = GetFrameValue
        Case "TPE1" 'アーティスト
            TagArtist = GetFrameValue
        Case "TALB" 'アルバム
            TagAlbum = GetFrameValue
        Case "TRCK" 'トラック
            TagTrackNo = GetFrameValue
        Case "TCON" 'ジャンル
            TagGenre = GetFrameValue
        Case "COMM" 'コメント
            TagComment = GetFrameValue
        Case "APIC" 'アートワーク
            
        Case Else
            
        End Select
        
        NextFrame '次のフレームを読み込む。
        
    Loop
    
    Location = backupLocation
    
End Sub


'sHex配列の数を返す。
Private Function sHex_getCount() As Long
    
    Dim iCnt As Long: iCnt = 0
    
    On Error GoTo Err1
    iCnt = UBound(sHex)
Err1:
    sHex_getCount = iCnt
    
End Function


'sHex配列から指定した範囲で文字列を取得し、そのまま返す。
Private Function sHex_getString(iStart As Long, iLen As Long, Optional sDelimiter As String = "") As String
    
    Dim tmp As String: tmp = ""
    Dim i As Long
    Dim iEnd As Long: iEnd = (iStart + iLen - 1)
    
    If sHex_getCount < iEnd Then iEnd = sHex_getCount
    
    For i = iStart To iEnd
        If Len(sDelimiter) > 0 And Len(tmp) > 0 Then tmp = tmp & sDelimiter
        tmp = tmp & sHex(i)
    Next
    sHex_getString = tmp
    
End Function


'sHex配列から指定した範囲で文字列を取得し、アスキー変換する。
Private Function sHex_getStringAscii(iStart As Long, iLen As Long) As String
    
    Dim tmp As String: tmp = ""
    Dim i As Long
    For i = iStart To (iStart + iLen - 1)
        tmp = tmp & Chr(HexToDec(sHex(i)))
    Next
    sHex_getStringAscii = tmp
    
End Function


'sHex配列から指定した範囲で文字列を取得し、Shift-JISに変換する。
Private Function sHex_getStringShiftJIS(iStart As Long, iLen As Long) As String
    
    Dim sFrameVal As String: sFrameVal = ""
    Dim i As Long, tmp As String
    Dim iEnd As Long: iEnd = (iStart + iLen - 1)
    
    For i = iStart To iEnd
        
        'If sHex(i) = "00" And i = iEnd Then Exit For '終了フラグ
        If sHex(i) = "00" Then Exit For '終了フラグ
        
        If Is2byteShiftJIS(sHex(i), sHex(i + 1)) Then
            tmp = sHex(i) & sHex(i + 1)
            i = i + 1
        Else
            tmp = sHex(i)
        End If
        
        sFrameVal = sFrameVal & Chr(HexToDec(tmp))
    Next
    
    sHex_getStringShiftJIS = sFrameVal
    
End Function


'sHex配列から指定した範囲で文字列を取得し、Unicodeに変換する。
Private Function sHex_getStringUTF16(iStart As Long, iLen As Long, flgBigEndian As Boolean) As String
    
    Dim sFrameVal As String: sFrameVal = ""
    Dim i As Long, tmp As String
    
    For i = iStart To (iStart + iLen - 1) Step 2
        If flgBigEndian Then
            tmp = sHex(i) & sHex(i + 1)
        Else
            tmp = sHex(i + 1) & sHex(i)
        End If
        If tmp = "0000" Then Exit For '終了フラグ
        
        sFrameVal = sFrameVal & ChrW(HexToDec(tmp))
    Next
    
    sHex_getStringUTF16 = sFrameVal
    
End Function


'sHex配列から指定した範囲で文字列を取得し、UTF-8に変換する。UTF-8はBE、LEの概念が無い。
Private Function sHex_getStringUTF8(iStart As Long, iLen As Long) As String
    
    Dim sFrameVal As String: sFrameVal = ""
    Dim tmp As String, tmpBin As String
    Dim i As Long, k As Long, iByte As Long
    Dim iEnd As Long: iEnd = (iStart + iLen - 1)
    
    For i = iStart To iEnd
        
        If sHex(i) = "00" Then Exit For '終了フラグ
        
        iByte = NumByteUTF8(sHex(i))
        If iByte = 0 Then Exit For
        
        Select Case iByte
        Case 1
            tmpBin = Right(HexToBin(sHex(i)), 7)
            
        Case 2 To 6
            tmpBin = Right(HexToBin(sHex(i)), 7 - iByte)
            
            For k = 1 To iByte - 1
                tmp = Right(HexToBin(sHex(i + k)), 6)
                tmpBin = tmpBin + tmp
            Next
            
        Case Else
            '到達不可
            
        End Select
        
        tmp = ChrW(BinToDec(tmpBin))
        sFrameVal = sFrameVal & tmp
        i = i + iByte - 1
        
    Next
    
    sHex_getStringUTF8 = sFrameVal
    
End Function


'UTF-8のバイト数を判定。
Private Function NumByteUTF8(sHex1 As String) As Integer
    
    Dim rtnInt As Integer
    Dim sBin As String: sBin = HexToBin(sHex1)
    
    Select Case True
    Case Left(sBin, 2) = "10"
        rtnInt = 0
        Debug.Print "先頭バイトではありません(" & sHex1 & ")"
    Case Left(sBin, 1) = "0"
        rtnInt = 1
    Case Left(sBin, 3) = "110"
        rtnInt = 2
    Case Left(sBin, 4) = "1110"
        rtnInt = 3
    Case Left(sBin, 5) = "11110"
        rtnInt = 4
    Case Left(sBin, 6) = "111110"
        rtnInt = 5
    Case Left(sBin, 7) = "1111110"
        rtnInt = 6
    Case Else
        rtnInt = 0
        Debug.Print "判別不能(" & sHex1 & ")"
    End Select
    
    NumByteUTF8 = rtnInt
    
End Function


'Shift-JISのバイト数を判定。超無理矢理。1or2バイト。
'2バイト文字の1バイト目は0x81～9F、0xE0～EF。
'2バイト文字の2バイト目は0x40～7F、0x80～FC。
'これ以外を1バイト文字と判定。
Private Function Is2byteShiftJIS(sHex1 As String, sHex2 As String) As Boolean
    
    Is2byteShiftJIS = False
    If (HexToDec("81") <= HexToDec(sHex1) And HexToDec(sHex1) <= HexToDec("9F")) Or _
       (HexToDec("E0") <= HexToDec(sHex1) And HexToDec(sHex1) <= HexToDec("EF")) Then
       If (HexToDec("40") <= HexToDec(sHex2) And HexToDec(sHex2) <= HexToDec("7F")) Or _
          (HexToDec("80") <= HexToDec(sHex2) And HexToDec(sHex2) <= HexToDec("FC")) Then
            Is2byteShiftJIS = True
        End If
    End If
    
End Function


'ヘッダーIDを取得(マジックナンバーID3固定)
Property Get GetHeaderID() As String
    
    '1～3バイト固定
    If sHex_getCount < 3 Then
        GetHeaderID = ""
    Else
        GetHeaderID = sHex_getStringAscii(1, 3)
    End If
    
End Property


'ID3v2のバージョンを取得。
Property Get GetVersion() As String
    
    Dim tmp As String
    
    If sHex_getCount < 5 Then
        tmp = ""
    Else
        Select Case sHex(4) & sHex(5) '4～5バイト固定
        Case "0200"
            tmp = "2"
        Case "0300"
            tmp = "3"
        Case "0400"
            tmp = "4"
        Case Else
            tmp = ""
        End Select
    End If
    
    GetVersion = tmp
    
End Property


'ヘッダーのフラグを渡す。非同期化、拡張ヘッダ、実験中等を示す。
Property Get GetHeaderFlg() As String
    
    '6バイト目固定
    If sHex_getCount < 6 Then
        GetHeaderFlg = ""
    Else
        GetHeaderFlg = sHex_getString(6, 1)
    End If
    
End Property


'ID3v2.3、v2.4であることを確認する。問題無ければ空文字を返す。
Function checkID3v2() As String
    
    Dim rtnStr As String: rtnStr = ""
    Dim tmp As String
    
    Dim iCnt As Long: iCnt = sHex_getCount
    If iCnt < 10 Then
        rtnStr = "読み込めませんでした。(size " & iCnt & ")": GoTo checkEnd
    End If
    
    If GetHeaderID <> "ID3" Then
        rtnStr = "ID3v2のヘッダーではありません": GoTo checkEnd
    End If
    
    tmp = GetVersion
    If tmp <> "3" And tmp <> "4" Then
        rtnStr = "ID3v2.3かID3v2.4である必要があります。(ID3v2." & tmp & ")": GoTo checkEnd
    End If
    
    tmp = GetHeaderFlg
    If tmp <> "00" Then
        rtnStr = "フラグ(" & tmp & ")を持つファイルです。読み込みを中止しました。": GoTo checkEnd
    End If
    
checkEnd:
    checkID3v2 = rtnStr
End Function


'ヘッダーに書かれている全体フレームサイズを渡す。
Property Get GetAllFrameSize() As Long
    
    '7～10バイト固定
    Dim tmp As String
    If sHex_getCount < 10 Then
        GetAllFrameSize = ""
    Else
        tmp = sHex(7) & sHex(8) & sHex(9) & sHex(10)
        GetAllFrameSize = HexToSyncsafeInteger(tmp)
    End If
    
End Property


'次のフレームを読み込む。
Public Sub NextFrame()
    
    If Location = 1 Then
        Location = 11
    Else
        Dim iFS As Long: iFS = GetFrameSize
        If iFS > 0 Then Location = Location + iFS + 10
    End If
    
End Sub


'指定されたフレームIDを探す。見つからなければ空文字を返す。
'本処理を使用してフレームが見つからなかった場合、Location情報は失われる。
Property Get SearchFrame(sFrameID As String) As String
    
    Location = 11
    
    Dim tmp As String
    Dim tmpFrameID As String: tmpFrameID = ""
    Dim iFS As Long
    
    Do While Location < GetAllFrameSize
        
        tmp = sHex_getString(Location, 1)
        If tmp = "00" Then Exit Do
        
        tmpFrameID = sHex_getStringAscii(Location, 4)
        If tmpFrameID = sFrameID Then Exit Do
        
        iFS = GetFrameSize
        If iFS > 0 Then Location = Location + iFS + 10
        
    Loop
    
    If tmpFrameID = sFrameID Then
        SearchFrame = tmpFrameID
    Else
        Location = 1
        SearchFrame = ""
    End If
    
End Property


'現在のフレームIDを渡す。各フレームの頭1～4バイト固定。
Property Get GetFrameID() As String
    
    If Location < GetAllFrameSize Then
        
        Dim tmp As String
        tmp = sHex_getString(Location, 1)
        
        If tmp = "00" Then
            GetFrameID = "" '1バイト目が00なら空文字を返す
        Else
            GetFrameID = sHex_getStringAscii(Location, 4)
        End If
    Else
        GetFrameID = ""
    End If
    
End Property


'現在のフレームサイズを渡す。各フレームの5～8バイト固定。
Property Get GetFrameSize() As Long
    
    Dim tmp As String
    tmp = sHex_getString(Location + 4, 4)
    GetFrameSize = HexToDec(tmp)
    
End Property


'現在フレームのフラグを返す。各フレームの9～10バイト固定。
Property Get GetFrameHeaderFlg() As String
    
    GetFrameHeaderFlg = sHex_getString(Location + 8, 2)
    
End Property


'現在フレームの値について、文字コード部を返す。
Property Get GetFrameCharacterCode() As String
    
    '00:ISO-8859-1、中身はShift-JISを想定。
    '01:UTF-16BOM有
    '02:UTF-16BOM無(v2.4)
    '03:UTF-8(v2.4)
    
    Dim tmp As String
    tmp = sHex_getString(Location + 10, 1)
    GetFrameCharacterCode = tmp
    
End Property


'現在フレームの値を返す。
Property Get GetFrameValue() As String
    
    Dim tmp As String
    Dim rtnStr As String: rtnStr = ""
    
    Dim thisLocation As Long
    thisLocation = Location + 10
    
    Dim strCode As String
    Dim flgBigEndian As Boolean
    Dim iOffset As Long
    
    '最初の1バイトは文字コード判別用。
    strCode = sHex_getString(thisLocation, 1)
    
    Select Case strCode
    
    Case "00" '00:ISO-8859-1、中身はShift-JISを想定。
        
        rtnStr = sHex_getStringShiftJIS(thisLocation + 1, GetFrameSize - 1)
        
    Case "01", "02" '01:UTF-16BOM有、02:UTF-16BOM無(v2.4)
        
        iOffset = 1 '文字コード分
        flgBigEndian = False
        tmp = sHex(thisLocation + 1) & sHex(thisLocation + 2) 'BOMの判別
        
        If tmp = "FEFF" Or strCode = "02" Then: flgBigEndian = True
        If tmp = "FEFF" Or tmp = "FFFE" Then iOffset = iOffset + 2 'BOM分
        
        rtnStr = sHex_getStringUTF16(thisLocation + iOffset, GetFrameSize - iOffset, flgBigEndian)
        
    Case "03" '03:UTF-8(v2.4)
        
        iOffset = 1 '文字コード分
        tmp = sHex_getString(thisLocation + 1, 3) 'BOMの判別。3バイト。
        
        If tmp = "EFBBBF" Then iOffset = iOffset + 3 'BOM分
        
        rtnStr = sHex_getStringUTF8(thisLocation + iOffset, GetFrameSize - iOffset)
        
    Case Else
        
        Debug.Print "文字コード指定がありません。開始文字(" & strCode & ")"
        rtnStr = sHex_getStringShiftJIS(thisLocation, GetFrameSize)
        
    End Select
    
    GetFrameValue = rtnStr
    
End Property


'主要抜粋。
Property Get GetFrameNameJP() As String
    
    Dim rtnStr As String
    
    Select Case GetFrameID
    Case ""
        rtnStr = ""
    Case "TIT2"
        rtnStr = "タイトル"
    Case "TPE1"
        rtnStr = "アーティスト"
    Case "TALB"
        rtnStr = "アルバム"
    Case "TCON"
        rtnStr = "ジャンル"
    Case "TRCK"
        rtnStr = "トラックNo"
    Case "TYER"
        rtnStr = "リリース年" 'TYER(v2.3)、TDRC(v2.4)
    Case "COMM"
        rtnStr = "コメント"
    Case "APIC"
        rtnStr = "アートワーク"
    Case Else
        rtnStr = ""
        Debug.Print "■フレーム「" & GetFrameID & "」初出"
    End Select
    
    GetFrameNameJP = rtnStr
    
End Property


'以下、デバッグ用。

'ヘッダーのバイナリを返す(デバッグ用)
Property Get GetHeaderBinary(Optional sDmt As String) As String
    GetHeaderBinary = sHex_getString(1, 10, sDmt)
End Property

'フレームのバイナリを返す(デバッグ用)
Property Get GetFrameBinary(Optional sDmt As String)
    GetFrameBinary = sHex_getString(Location, GetFrameSize + 10, sDmt)
End Property

'ID3v2の全バイナリを返す。mp3本体以降は含まない。(デバッグ用)
Property Get GetAllTagBinary(Optional sDmt As String)
    GetAllTagBinary = sHex_getString(1, GetAllFrameSize + 10, sDmt)
End Property

書き換えはタグ編集ソフトでやる。

以上。

mp3バイナリ解析準備

Excel VBA ファイル処理

必要なものを作っていく。


16進数と2進数の10進数変換

マイナスや小数点以下の数値、エラーを考慮せずに作ったので取扱注意。

'16進数を2進数に変換
Function HexToBin(sHex As String) As String
    Dim rtnStr As String: rtnStr = ""
    Dim i As Long, tmp As String
    
    For i = Len(sHex) To 1 Step -1
        tmp = WorksheetFunction.Hex2Bin(Mid(sHex, i, 1))
        tmp = Right("000" & tmp, 4) '桁埋め
        rtnStr = tmp & rtnStr
    Next
    
    HexToBin = rtnStr
End Function

'2進数を10進数に変換
Function BinToDec(sBin As String) As Long
    Dim tmp As String
    tmp = StrReverse(sBin) '文字を逆にする
    Dim iSum As Long: iSum = 0
    Dim i As Long
    
    For i = 1 To Len(tmp)
        If Mid(tmp, i, 1) = "1" Then
            iSum = iSum + 2 ^ (i - 1)
        End If
    Next
    
    BinToDec = iSum
End Function

'16進数を10進数に変換
Function HexToDec(sHex As String) As Long
    HexToDec = BinToDec(HexToBin(sHex))
End Function


Syncsafe Integer計算用。
ID3v2系のヘッダのサイズを調べるために使う。v2.3ではヘッダのみ。他にも使われるかもしれない。

'Syncsafe Integerを計算。16進数を10進数で返却。
'最上位8ビット目をスキップして連結
Function HexToSyncsafeInteger(sHex As String) As Long
    Dim rtnStr As String: rtnStr = ""
    Dim tmp As String
    tmp = HexToBin(sHex) '16進数を2進数に変換
    tmp = StrReverse(tmp) '文字を逆にする
    
    '最上位8ビット目をスキップして連結
    Dim i As Long
    For i = 1 To Len(tmp)
        If i Mod 8 <> 0 Then rtnStr = Mid(tmp, i, 1) & rtnStr
    Next
    
    HexToSyncsafeInteger = BinToDec(rtnStr)
End Function


上記で作ったもののテスト

'引数は16進数そのまま

'アスキーコードの変換テスト
Debug.Print Chr(HexToDec("49")) '49 44 33→ID3

'ヘッダサイズ取得テスト（Syncsafe Integer）
Debug.Print HexToSyncsafeInteger("00001000") '2048バイト

'フレームサイズ取得テスト
Debug.Print HexToDec("00000019") '25バイト

'UTF-16の変換テスト
Debug.Print ChrW(HexToDec("9F8D")) '龍

'Shift-JISの変換テスト
Debug.Print Chr(HexToDec("97B4")) '龍

あとはmp3のバイナリ構造に合わせて読み出すように組めばOK。


全体の構造ざっくり

ID3v1系はファイルの末尾にタグ情報がある。当記事では取り扱わない。
ID3v2系はファイルの先頭にタグ情報がある。「49 44 33」と書かれている。これをアスキーコードで表すと「ID3」である。
ID3v2のヘッダ10バイト+ヘッダサイズ（Syncsafe Integer）の次にmp3の曲本体がある。
mp3の曲本体はFFFBから始まる。
使われていない部分は0で埋められている。


id3v2.3、id3v2.4のヘッダー
先頭10バイト
場所長さ内容備考
1～33識別子「49 44 33」が入っている。アスキーコードで「ID3」。
4～52バージョン「02 00」「03 00」「04 00」のいずれかが入っている。
それぞれv2.2、v2.3、v2.4を表す。
61フラグ非同期化、拡張ヘッダ、実験中などを表す。基本は「00」。
本記事では「00」以外のパターンは謎とする。
7～104サイズフレーム全体のサイズ。Syncsafe Integer。


id3v2.3、id3v2.4のフレーム
ヘッダーの直後、11バイト目以降
場所長さ内容備考
1～44フレームID「TIT2」「TPE1」「TALB」などが入る。
アスキーコードで書かれる。
5～84フレームサイズデータ本体のサイズが入っている。
フレームサイズ10バイトは含まれない。
9～102フラグ謎。
11～1～可変データ本体文字コード、BOM、文字の順で書かれる。


主なフレームID(v2.3)

フレームID 内容
TIT2タイトル
TPE1アーティスト
TALBアルバム
TCONジャンル
TRCKトラックNo
TYERリリース年
COMMコメント
APICアートワーク


文字コード

フレームデータの1バイト目に文字コードが書かれる。
値文字コード備考
00ISO-8859-1
01UTF-16BOM有
02UTF-16BOM無(v2.4)
03UTF-8(v2.4)

00が指定されていてもShift-JISが入っていることがあるので注意。

※1バイト目からテキストデータが始まる例を確認したが、フレームIDが「T〇〇〇」とは違った。特殊な例なのだろうか。


BOM（Byte Order Mark）

文字の読み取り順を指定するもので文字データの頭に、UTF-16は「FFFE」「FEFF」のどちらか、UTF-8は「EF BB BF」が書かれる。

FFFEはリトルエンディアン、FEFFはビッグエンディアン。
v2.3はUTF-16で必ずBOMが付くので、それで判断する。多分リトルエンディアン。

'UTF-16の変換テスト
Debug.Print ChrW(HexToDec("9F8D")) '龍

この例ではv2.3に「8D9F」と書かれており、前後を入れ替えて「9F8D」にした。リトルエンディアンは交互に書かれている。
ビッグエンディアンはそのままの順番で書かれる。

UTF-8のBOMは「EF BB BF」だが、そもそもUTF-8はBEかLEかの区別が無い。BOMの有無に関係無く書かれている順に処理する。


文字列の終了フラグ

UTF-16の文字の終わりは「00 00」。
Shift-JISの文字の終わりは「00」。
UTF-8の文字の終わりは「00」。

最終バイト以外で終了フラグが出る場合は以降を無視するらしい。フレームサイズに注意して読む。


UTF-8

16進数を2進数にして、最初の1バイト目を見る。

最初のビットが0なら1バイト文字。以下7ビットが有効。
最初のビットが110なら2バイト文字。以下5ビット+次の1バイトの下6ビットが有効。
最初のビットが1110なら3バイト文字。以下4ビット+次と次の1バイトの下6(略)。
最初のビットが11110なら4バイト文字。以下3ビット+次と次と次の(略)
最初のビットが10なら、最初のビットではない。
上記以外なら、UTF-8ではない。


※表のx部分が有効ビット
nバイト文字1バイト2バイト3バイト4バイト
10xxxxxxx
2110xxxxx10xxxxxx
31110xxxx10xxxxxx10xxxxxx
411110xxx10xxxxxx10xxxxxx10xxxxxx

有効ビットを全て繋げて16進数に変換すればユニコード番号になる。
10進数に変換してChrW変換をかければ文字が出る。


例）E9BE8D
→11101001 10111110 10001101
→1001 111110 001101→1001 1111 1000 1101
→9F8D（10進数で40845）
→龍


以下、UTF-8変換テストコード

'テスト。「龍」が出る予定。
Private Sub test_getStringUTF8()
    
    Dim testString(1 To 3) As String
    testString(1) = "E9"
    testString(2) = "BE"
    testString(3) = "8D"
    
    Dim iStart As Long: iStart = 1
    Dim iLen As Long: iLen = 3
    
    Dim sFrameVal As String: sFrameVal = ""
    Dim tmp As String, tmpBin As String
    Dim i As Long, k As Long, iByte As Long
    Dim iEnd As Long: iEnd = (iStart + iLen - 1)
    
    For i = iStart To iEnd
        
        If testString(i) = "00" Then Exit For '終了フラグ
        
        iByte = NumByteUTF8(testString(i))
        If iByte = 0 Then Exit For
        
        Select Case iByte
        Case 1
            tmpBin = Right(HexToBin(testString(i)), 7)
            
        Case 2 To 6
            tmpBin = Right(HexToBin(testString(i)), 7 - iByte)
            
            For k = 1 To iByte - 1
                tmp = Right(HexToBin(testString(i + k)), 6)
                tmpBin = tmpBin + tmp
            Next
            
        Case Else
            '到達不可
            
        End Select
        
        tmp = ChrW(BinToDec(tmpBin))
        sFrameVal = sFrameVal & tmp
        i = i + iByte - 1
        
    Next
    
    Debug.Print sFrameVal '龍
    
End Sub


'UTF-8のバイト数を判定。
Private Function NumByteUTF8(sHex1 As String) As Integer
    
    Dim rtnInt As Integer
    Dim sBin As String: sBin = HexToBin(sHex1)
    
    Select Case True
    Case Left(sBin, 2) = "10"
        rtnInt = 0
        Debug.Print "先頭バイトではありません(" & sHex1 & ")"
    Case Left(sBin, 1) = "0"
        rtnInt = 1
    Case Left(sBin, 3) = "110"
        rtnInt = 2
    Case Left(sBin, 4) = "1110"
        rtnInt = 3
    Case Left(sBin, 5) = "11110"
        rtnInt = 4
    Case Left(sBin, 6) = "111110"
        rtnInt = 5
    Case Left(sBin, 7) = "1111110"
        rtnInt = 6
    Case Else
        rtnInt = 0
        Debug.Print "判別不能(" & sHex1 & ")"
    End Select
    
    NumByteUTF8 = rtnInt
    
End Function


Shift-JIS

1～2バイト文字。
バイナリから復元するには1～2バイト文字の判別が必要。

'Shift-JISのバイト数を判定。1or2バイト。超無理矢理。
'2バイト文字の1バイト目は0x81～9F、0xE0～EF。
'2バイト文字の2バイト目は0x40～7F、0x80～FC。
'これ以外を1バイト文字と判定。
Function Is2byteShiftJIS(sHex1 As String, sHex2 As String) As Boolean
    
    Is2byteShiftJIS = False
    If (HexToDec("81") <= HexToDec(sHex1) And HexToDec(sHex1) <= HexToDec("9F")) Or _
       (HexToDec("E0") <= HexToDec(sHex1) And HexToDec(sHex1) <= HexToDec("EF")) Then
       If (HexToDec("40") <= HexToDec(sHex2) And HexToDec(sHex2) <= HexToDec("7F")) Or _
          (HexToDec("80") <= HexToDec(sHex2) And HexToDec(sHex2) <= HexToDec("FC")) Then
            Is2byteShiftJIS = True
        End If
    End If
    
End Function



かじった程度の知識しかないのでフラグや拡張ヘッダーについては触れません。
サロゲートペア文字は知らなかったことにして回避しました。

次の記事でmp3タグ解析用(v2)のプログラムを書きます。

以上。

mp3のタグ文字化け

その他

ナビで音楽を再生→文字化け発見→
→タグ編集ソフトでUnicodeに書き換える
→文字化けなおる！

インターネットで少し調べれば上記の事は分かるけど、編集時や運用で気を付けることがあるのでメモメモ。

色々書く。



wmaの「アルバムのアーティスト」

いきなり文字化けとは違うけど苦労した件をメモ。

私の使ってるナビはアルバム一覧が表示できる。

このナビはwmaを「アルバムのアーティスト」と「アルバム」の組み合わせでアルバムを認識する模様。

同じアルバム内でアーティストが複数いる場合があり、アルバムのアーティストに「VA」だか「さまざまなアーティスト」を入れることで同一アルバムと認識させる事ができる。これをナビで再生すると「さまざまなアーティスト」さんが歌っていると表示される。私は嫌。

それならばと、アルバムのアーティストに個別のアーティスト名を入れると、ズラズラと同じアルバム名が並んで判別不可能に。

アルバムのアーティストの中身を消すと「Unknown Artist」とナビに表示された。アーティストタグに登録されている名前は出ない模様。詰んだ。
wmaと異なるタグを有するmp3との共存は難しい。

wmaは消した。諦めた。
mp3の1本でいきます。

※この件はアルバム一覧を使わない事で解決する事ができる。

※ナビの説明書に「アルバムのアーティスト」という単語は無かった。ふしぎ！



文字化け対策

タグ編集ソフトを使ってUnicode(UTF-16)に書き換えると解決！UTF-8でも可！

上記で書き換えた後にファイルのプロパティを編集すると、書き換えたタグの文字コードが変わるので注意。関係ない項目を変更しても変わるのは理不尽だと思う。

※稀にUTF-16LEで文字化けするパターンに遭遇して調査中。これは別記事で書く。



Gracenote

タグ編集ソフトで登録したタグとは違う文字がナビに表示される事がある。改名前の名前を入れたのに改名後の名前が出たり、半角で入れたのに全角表示されたり。気付きにくいのも嫌だ。

Gracenoteはナビ等に備わっているタグ情報を更新してくれるサービス。仕組みは謎。

犯人はGracenote。
正しく黙らせる方法を知りたい。

強制的に黙らせる方法はインターネットで検索すると出てくる。ナビでGracenoteのアップデート途中に電源を(略)、復活も可能との事だが、自分のではやりたくない。

長いタイトル、アーティスト名、アルバム名とか、ナビ画面の横幅が足りなくて表示しきれない事が多々ある。だから編集してるのにGracenoteが勝手に(略)

ナビもナビで横スクロールくらいしてほしい。



上記に書いてない文字化けまとめ

文字化けの原因は、指定されてる文字コードを守ってないから。

id3v1系ではシフトJISが使えた。しかしid3v2系の規格にシフトJISは無い。それでもシフトJISを使いたいヤツがいた。文字コードISO8859-1と指定されてる所にシフトJISの文字をブッ込むやり方が蔓延した。そりゃ文字化けするわ。

インターネットで「文字コードはシフトJISで書き込んで下さい」とハッキリ書いてある公式説明書(PDF)も見つけた。v1～v2対応らしい。草生える。


タグ編集ソフトを使ってUnicodeを指定する！
古い機器で再生しないならid3v1のタグは消す！タグ編集ソフトで消せる！

タグ編集ソフトを使う！


※古い機器でもタグを表示できるようにとv2で規定された非同期化という技術とUnicodeの組み合わせで文字化けする例もあるらしいけど、これについては文字化けに遭遇してから考えます。

以上。