vbaのFileSystemobjectでコメントの取得、フォルダ名の表示、一部のフォルダ名、ファイル名、拡張子の除外

Question

現在、excelのvbaでファイルリスト一覧を表示させるプログラムを作成しています。その際に、どのように実装したらよいかネットなどで調べてもわからないので質問させていただきました。当方プログラミング自体ほぼほぼ初心者で分かりやすく解説していただけると大変うれしいです。

実装したいこと

• for each文のループ中のWorksheets("ファイル一覧").Cells(IRow, 5) = ""ここの""の処理にファイルプロパティからコメントの取得したい。
• Worksheets("ファイル一覧").Hyperlinks.Add Anchor:=Cells(IRow, 7), Address:=strPath, TextToDisplay:=(フォルダ名)ここの処理の()の部分でフォルダ名を表示させてたい。
• ファイル一覧を表示させるのですがファイル名、フォルダ名、拡張子が以下の文字を含む場合は除外tmp,temp,bk,bak,~$, - コピー

ソースプログラムはこちらになります。

Option Explicit

Public IRow As Variant
Public number As Variant

Sub サブフォルダを含むファイルデータを取得()
    
    IRow = 1
    number = 0
    Sheets("ファイル一覧").Select
    
    Call ファイル名取得("C:\Users\hi610\OneDrive\ドキュメント\temp")
End Sub
Sub ファイル名取得(strPath As Variant)
    Dim FSO As Object, Folder As Object, File As Object, objDP As DocumentProperties
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    For Each File In FSO.GetFolder(strPath).Files
        If Not number = 4 Then
            IRow = IRow + 1
            number = number + 1
            Dim dps As DocumentProperties
            Dim dp As DocumentProperty
            Worksheets("ファイル一覧").Cells(IRow, 1).Value = number
            Worksheets("ファイル一覧").Cells(IRow, 2) = FSO.GetBaseName(File.Path)
            Worksheets("ファイル一覧").Cells(IRow, 3) = File.DateCreated
            Worksheets("ファイル一覧").Cells(IRow, 4) = File.DateLastModified
            Worksheets("ファイル一覧").Cells(IRow, 5) = ""
            Worksheets("ファイル一覧").Hyperlinks.Add Anchor:=Cells(IRow, 6), Address:=File.Path, TextToDisplay:=File.Name
            Worksheets("ファイル一覧").Hyperlinks.Add Anchor:=Cells(IRow, 7), Address:=strPath, TextToDisplay:=File.Path
        Else
            Exit For
        End If
    Next
    
    For Each Folder In FSO.GetFolder(strPath).SubFolders
        Call ファイル名取得(Folder)
    Next
    
    Set FSO = Nothing
    Set Folder = Nothing
    Set File = Nothing
End Sub

自分で試したこと
フォルダ名を取得する処理ですがfor eachでfilesystemobjectのfilesプロパティを使用しているため、object.Nameではファイル名が表示されてしまう。なので二重ループにして(例:for each ~ .Folders)プロパティをフォルダ名を取得しようとしたがオブジェクトの参照ができなかった

一部の文字を除外することに関しましてはif not Like File.Name Like ".tmp" And File.Name "tmp."とfor each中にネストとしていったが処理が途中で終わってしまう。またこの場合、一部の文字を含むフォルダ名を除外する方法が検討もつかない。

ファイルプロパティからコメントを取得する方法は調べたがよくわからなかった。

現状このような感じです。誰かわかる方いらしたらご回答お願いします。

Comments

[tatsu99]

If Not number = 4 Then
この行の為、ファイルが４件しか出力されませんが、意図した動作でしょうか。

[gaint]

設計者でレコードの6件目以降はファイル一覧を表示させないという記載があったためこのような処理をしています。

Answer 1

ファイルプロパティのコメントの取得については、下記が参考になります。
コメント取得
Sub Sample8()が参考になります。

windows7での確認なので、参考程度にしてください。
出力件数に制約は設けていません。
コメントはFolder.GetDetailsOf(Folder.ParseName(File_name), 24)で取得しています。
24の数値は、Sub Sample9()を実行してコメント用の番号を取得しています。
コメントは普通のテキストファイルなどでは取得対象外となります。

Option Explicit

Public IRow As Variant
Public number As Variant
Public ws As Worksheet

Sub サブフォルダを含むファイルデータを取得()

    IRow = 1
    number = 0
    Dim maxrow As Long
    Set ws = Worksheets("ファイル一覧")
    maxrow = ws.Cells(Rows.Count, 1).End(xlUp).Row '最終行を求める
    If maxrow > 1 Then
        ws.Rows("2:" & maxrow).ClearContents
    End If

    Call ファイル名取得("C:\Users\hi610\OneDrive\ドキュメント\temp")
End Sub
Sub ファイル名取得(strPath As Variant)
    Dim FSO As Object, Folder As Object, File As Object, objDP As DocumentProperties

    Set FSO = CreateObject("Scripting.FileSystemObject")

    For Each File In FSO.GetFolder(strPath).Files
        If IsJogai(File.name) = False Then
        IRow = IRow + 1
        number = number + 1
        Dim dps As DocumentProperties
        Dim dp As DocumentProperty
        ws.Cells(IRow, 1).Value = number
        ws.Cells(IRow, 2) = FSO.GetBaseName(File.path)
        ws.Cells(IRow, 3) = File.DateCreated
        ws.Cells(IRow, 4) = File.DateLastModified
        ws.Cells(IRow, 5) = getComment(strPath, File.name)
        ws.Hyperlinks.Add Anchor:=Cells(IRow, 6), Address:=File.path, TextToDisplay:=File.name
        ws.Hyperlinks.Add Anchor:=Cells(IRow, 7), Address:=strPath, TextToDisplay:=strPath
        End If
    Next

    For Each Folder In FSO.GetFolder(strPath).SubFolders
        Call ファイル名取得(Folder.path)
    Next

    Set FSO = Nothing
    Set Folder = Nothing
    Set File = Nothing
End Sub

Function getComment(ByVal path As String, ByVal File_name As String)
    Dim Shell As Object
    Dim Folder As Object
    Set Shell = CreateObject("Shell.Application")
    Set Folder = Shell.Namespace(path & "\")
    getComment = Folder.GetDetailsOf(Folder.ParseName(File_name), 24)
    Set Folder = Nothing
    Set Shell = Nothing
End Function

Function IsJogai(ByVal File_name As String) As Boolean
    Dim names As Variant
    Dim name As Variant
    IsJogai = True
    names = Array("tmp", "temp", "bk", "bak", "~$", "- コピー")
    For Each name In names
        If InStr(LCase(File_name), LCase(name)) > 0 Then
            Exit Function
        End If
    Next
    IsJogai = False
End Function

Comments

[gaint]

コードまで丁寧に記述してくださりありがとうございます。実装してみます。

Answer 2

ファイル名、フォルダ名、拡張子が一部の文字を含む場合の除外とハイパーリンクのフォルダ名の表示は自己解決できました。
ファイルプロパティのコメントの取得はまだできていないのでわかる方いましたらよろしくお願いします