Sub ファイルパス一覧作成()
'≪A3以降のファイル情報を書き込むセルとD1セルを最初にクリアにする≫
Range(Cells(3, 1), Cells(Rows.Count, Columns.Count)).Clear
Cells(1, 2).Clear
'≪取得したいフォルダをダイアログボックスを開いて選択する≫
Dim 指定フォルダのパス As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "ファイル一覧を作成したいフォルダを選択してください"
If .Show = -1 Then
指定フォルダのパス = .SelectedItems(1)
Cells(1, 2).Value = "情報を取得するフォルダ：" & 指定フォルダのパス
Else
MsgBox "中止しました。"
Exit Sub
End If
End With
'≪ファイルパス一覧を作成する≫
Dim myFSO As New FileSystemObject
Dim myRootFolder As Folder
Set myRootFolder = myFSO.GetFolder(指定フォルダのパス)
Cells(3, 1).Select 'ファイル情報を表示する最初のセルを選択する
ファイルパス書出 myRootFolder '後述の「ファイルパス書出」を呼び出して実行する。
Set myFSO = Nothing 'メモリリークによるエラーを防ぐためにFSOを終了させる
'≪拡張子なしのファイル名を書き込む≫
Dim objFSO As New FileSystemObject
Dim 拡張子無ファイル名 As String
Dim フルパス As String
Dim 行数 As Long
Dim 最終行 As Long
最終行 = Cells(Rows.Count, 1).End(xlUp).Row
For 行数 = 3 To 最終行
フルパス = Cells(行数, 5).Value
拡張子無ファイル名 = objFSO.GetBaseName(フルパス)
Cells(行数, 2).Value = 拡張子無ファイル名
Next 行数
Set objFSO = Nothing 'メモリリークによるエラーを防ぐためにFSOを終了させる
'≪アーティスト名を書き込む≫
Dim Shell As Variant
Dim Folder As Variant
Dim 拡張子付ファイル名 As Variant
Dim フルパスその2 As Variant
Dim ファイルのフォルダパス As Variant
Dim 行数その2 As Long
Dim 最終行その2 As Long
最終行その2 = Cells(Rows.Count, 1).End(xlUp).Row
For 行数その2 = 3 To 最終行その2
拡張子付ファイル名 = Cells(行数その2, 1).Value
フルパスその2 = Cells(行数その2, 5).Value
ファイルのフォルダパス = Replace(フルパスその2, 拡張子付ファイル名, "") 'フルパスから拡張子付ファイル名を抜くようにVBAのReplace関数を使った
Set Shell = CreateObject("Shell.Application")
Set Folder = Shell.Namespace(ファイルのフォルダパス)
Cells(行数その2, 3).Value = Folder.GetDetailsOf(Folder.ParseName(拡張子付ファイル名), 20) 'アーティスト名の取得(引数20番がアーティスト名)と書き込み
Next 行数その2
Set Shell = Nothing 'メモリリークによるエラーを防ぐためにFSOを終了させる
Set Folder = Nothing 'メモリリークによるエラーを防ぐためにFSOを終了させる
'≪最上段を表示した状態にしておきたいのでA3セルを選択状態にする≫
Cells(3, 1).Select
'≪最後に書き出しが完了したことをお知らせする≫
MsgBox "ファイル情報の書き出しが完了しました。"
End Sub
Sub ファイルパス書出(ByRef myParentFolder As Folder)
Dim myFolders As Folders
Dim myFolder As Folder
Dim myFiles As Files
Dim myFile As File
Set myFolders = myParentFolder.SubFolders
If myFolders.Count <> 0 Then
For Each myFolder In myFolders
ファイルパス書出 myFolder
Next myFolder
End If
Set myFiles = myParentFolder.Files
If myFiles.Count <> 0 Then
For Each myFile In myFiles
With ActiveCell
.Value = myFile.Name 'ファイル名を取得する
.Offset(0, 4) = myFile.Path 'フルパスを取得する
.Offset(1, 0).Select
End With
Next myFile
End If
End Sub
こんばんは。
