エクスプローラで選択されているファイルの選択解除するショートカット。
Ctrl+Space
以上。
ファイルやフォルダを選択してShiftを押しながら右クリック。
フルパスが取得できる。パスはダブルクォーテーションで囲まれている。複数選択可。
以上。
どれもフォルダを開く処理。エラー処理を忘れないこと。
ThisWorkbook.FollowHyperlink folderPath CreateObject("WScript.Shell").Run folderPath shell "explorer " & folderPath, vbNormalFocus ' ファイルを選択した状態でフォルダを開く。フルパスであることに注意。 shell "explorer /select, " & fullPath, vbNormalFocus
フルパスからフォルダパスを取得する1例。
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
以上。
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 | 秘書の電話 |
65 | FAX 番号 (会社) | 65 | 誕生日 |
66 | 会社のホーム ページ | 66 | 住所 (会社) |
67 | 会社電話 | 67 | 市 (会社) |
68 | コールバック番号 | 68 | 国/地域 (会社) |
69 | 自動車電話 | 69 | 私書箱 (会社) |
70 | 子供 | 70 | 郵便番号 (会社) |
71 | 会社代表電話 | 71 | 都道府県 (会社) |
72 | 部署 | 72 | 番地 (会社) |
73 | 電子メール アドレス | 73 | FAX 番号 (会社) |
74 | 電子メール2 | 74 | 会社のホーム ページ |
75 | 電子メール3 | 75 | 会社電話 |
76 | 電子メールの一覧 | 76 | コールバック番号 |
77 | 電子メール表示名 | 77 | 自動車電話 |
78 | 表題2 | 78 | 子供 |
79 | 名 | 79 | 会社代表電話 |
80 | 氏名 | 80 | 部署 |
81 | 性別 | 81 | 電子メール アドレス |
82 | 名2 | 82 | 電子メール2 |
83 | 趣味 | 83 | 電子メール3 |
84 | 住所 (自宅) | 84 | 電子メールの一覧 |
85 | 市 (自宅) | 85 | 電子メール表示名 |
86 | 国/地域 (自宅) | 86 | 表題2 |
87 | 私書箱 (自宅) | 87 | 名 |
88 | 郵便番号 (自宅) | 88 | 氏名 |
89 | 都道府県 (自宅) | 89 | 性別 |
90 | 番地 (自宅) | 90 | 名2 |
91 | 自宅 FAX | 91 | 趣味 |
92 | 自宅電話 | 92 | 住所 (自宅) |
93 | IM アドレス | 93 | 市 (自宅) |
94 | イニシャル | 94 | 国/地域 (自宅) |
95 | 役職 | 95 | 私書箱 (自宅) |
96 | ラベル | 96 | 郵便番号 (自宅) |
97 | 姓 | 97 | 都道府県 (自宅) |
98 | 住所 (郵送先) | 98 | 番地 (自宅) |
99 | ミドル ネーム | 99 | 自宅 FAX |
100 | 携帯電話 | 100 | 自宅電話 |
101 | ニックネーム | 101 | IM アドレス |
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 | 私書箱 (郵送先) |
123 | TTY/TTD 電話 | 123 | 郵便番号 (郵送先) |
124 | テレックス | 124 | 都道府県 |
125 | Web ページ | 125 | 番地 (郵送先) |
126 | 内容の状態 | 126 | プライマリ電子メール |
127 | 内容の種類 | 127 | 通常の電話 |
128 | 取得日時 | 128 | 職業 |
129 | アーカイブ日時 | 129 | 配偶者 |
130 | 完了日 | 130 | サフィックス |
131 | デバイス カテゴリ | 131 | TTY/TTD 電話 |
132 | 接続済み | 132 | テレックス |
133 | 探索方法 | 133 | Web ページ |
134 | フレンドリ名 | 134 | 内容の状態 |
135 | ローカル コンピューター | 135 | 内容の種類 |
136 | 製造元 | 136 | 取得日時 |
137 | モデル | 137 | アーカイブ日時 |
138 | ペアリング済み | 138 | 完了日 |
139 | クラス | 139 | デバイス カテゴリ |
140 | 状態 | 140 | 接続済み |
141 | クライアント ID | 141 | 探索方法 |
142 | 貢献者 | 142 | フレンドリ名 |
143 | コンテンツの作成日時 | 143 | ローカル コンピューター |
144 | 前回印刷日 | 144 | 製造元 |
145 | 前回保存日時 | 145 | モデル |
146 | 事業部 | 146 | ペアリング済み |
147 | ドキュメント ID | 147 | クラス |
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 | 日付時刻 |
190 | URL | 190 | フォルダー名 |
191 | メディアの作成日時 | 191 | フォルダーのパス |
192 | リリース日 | 192 | フォルダー |
193 | エンコード方式 | 193 | 参加者 |
194 | プロデューサー | 194 | パス |
195 | 発行元 | 195 | 場所ごと |
196 | サブタイトル | 196 | 種類 |
197 | ユーザー Web URL | 197 | 連絡先の名 |
198 | 作者 | 198 | 履歴の種類 |
199 | 添付ファイル | 199 | 言語 |
200 | BCC アドレス | 200 | 最終表示日 |
201 | BCC | 201 | 説明 |
202 | CC アドレス | 202 | リンクの状態 |
203 | CC | 203 | リンク先 |
204 | 会話 ID | 204 | URL |
205 | 受信日時 | 205 | |
206 | 送信日時 | 206 | |
207 | 送信元アドレス | 207 | |
208 | 差出人 | 208 | メディアの作成日時 |
209 | 添付ファイルの有無 | 209 | リリース日 |
210 | 送信者アドレス | 210 | エンコード方式 |
211 | 送信者名 | 211 | エピソード番号 |
212 | ストア | 212 | プロデューサー |
213 | 送信先アドレス | 213 | 発行元 |
214 | To do タイトル | 214 | シーズン番号 |
215 | 宛先 | 215 | サブタイトル |
216 | 経費情報 | 216 | ユーザー Web URL |
217 | アルバムのアーティスト | 217 | 作者 |
218 | アルバム ID | 218 | |
219 | ビート数/分 | 219 | 添付ファイル |
220 | 作曲者 | 220 | BCC アドレス |
221 | イニシャル キー | 221 | BCC |
222 | コンパイルの一部 | 222 | CC アドレス |
223 | 雰囲気 | 223 | CC |
224 | セットのパート | 224 | 会話 ID |
225 | 期間 | 225 | 受信日時 |
226 | 色 | 226 | 送信日時 |
227 | 保護者による制限 | 227 | 送信元アドレス |
228 | 保護者による制限の理由 | 228 | 差出人 |
229 | 使用領域 | 229 | 添付ファイルの有無 |
230 | EXIF バージョン | 230 | 送信者アドレス |
231 | イベント | 231 | 送信者名 |
232 | 露出補正 | 232 | ストア |
233 | 露出プログラム | 233 | 送信先アドレス |
234 | 露出時間 | 234 | To do タイトル |
235 | 絞り値 | 235 | 宛先 |
236 | フラッシュ モード | 236 | 経費情報 |
237 | 焦点距離 | 237 | アルバムのアーティスト |
238 | 35mm 焦点距離 | 238 | アルバム アーティストで並べ替え |
239 | ISO 速度 | 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 | 字幕 | 255 | EXIF バージョン |
256 | 再放映 | 256 | イベント |
257 | SAP | 257 | 露出補正 |
258 | 放送日 | 258 | 露出プログラム |
259 | プログラムの説明 | 259 | 露出時間 |
260 | 記録時間 | 260 | 絞り値 |
261 | ステーション コール サイン | 261 | フラッシュ モード |
262 | 局名 | 262 | 焦点距離 |
263 | 概要 | 263 | 35mm 焦点距離 |
264 | 抜粋 | 264 | ISO 速度 |
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 | データ速度 | 282 | SAP |
283 | フレーム高 | 283 | 放送日 |
284 | フレーム率 | 284 | プログラムの説明 |
285 | フレーム幅 | 285 | 記録時間 |
286 | 総ビット レート | 286 | ステーション コール サイン |
287 | 287 | 局名 | |
288 | 288 | 概要 | |
289 | 289 | 抜粋 | |
290 | 290 | 自動要約 | |
291 | 291 | 関連度 | |
292 | 292 | ファイルの所有権 | |
293 | 293 | 秘密度 | |
294 | 294 | 共有ユーザー | |
295 | 295 | 共有状態 | |
296 | 296 | ||
297 | 297 | 製品名 | |
298 | 298 | 製品バージョン | |
299 | 299 | サポートのリンク | |
300 | 300 | ソース | |
301 | 301 | 開始日 | |
302 | 302 | 共有中 | |
303 | 303 | 可用性の状態 | |
304 | 304 | 状態 | |
305 | 305 | 課金情報 | |
306 | 306 | 完了 | |
307 | 307 | 仕事の所有者 | |
308 | 308 | タイトルで並べ替え | |
309 | 309 | 総ファイル サイズ | |
310 | 310 | 商標 | |
311 | 311 | ビデオ圧縮 | |
312 | 312 | ディレクター | |
313 | 313 | データ速度 | |
314 | 314 | フレーム高 | |
315 | 315 | フレーム率 | |
316 | 316 | フレーム幅 | |
317 | 317 | 球形 | |
318 | 318 | ステレオ | |
319 | 319 | ビデオの向き | |
320 | 320 | 総ビット レート |
以上。
円と弧円の組み合わせで描く。
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
中央の小さい円は、円弧の半径-外側の円の半径で求まる。
上記を計算しながらオートシェイプを配置。
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度。
以上。
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
書き換えはタグ編集ソフトでやる。
以上。