vbaでオフィスファイルのプロパティのコメント取得、一部の拡張子を含むファイルの除外(小文字か大文字どちらかに変換して除外)

vbaでオフィスファイル(wordやexcel)などのプロパティからコメントを取得する方法がさっぱりわからず、質問させていただきました。設計書にはbuiltindocumentpropertiesを使ってオフィスファイルからコメントを取得するようにかいてあったので、builtindocumentpropertiesを使ってコメントを取得したいです。

また、拡張子、ファイル名がtmp、temp、bk、bakを含むファイルを大文字または小文字どちらの場合でも除外できる方法も知りたいです。ifのネストで記述していたのですがこれだと可読性が低くなるというご指摘がありました。ifのネスト以外でファイル名や拡張子を判定する処理をfunctionプロシージャを使って処理したいです。

お手数をおかけして申し訳ございませんがわかる方よろしくお願いします。

vba
Option Explicit
Sub サブフォルダ含むファイルデータ取得()
    Dim intIchi As Integer
    Dim strPath As String
    
     intIchi = 2          '開始行
    
     strPath = Worksheets("保管場所").Range("B3").Value          'ファイルパス取得
    
    Sheets("ファイル一覧").Select　　　　’シート選択
    
    Call ファイル名取得(strPath, intIchi)
    Call 空欄削除
    Call 連番挿入
End Sub

Sub ファイル名取得(strPath As String, intIchi As Integer)
    Dim objFSO As Object, objFile As Object, objsubFolder 'オブジェクト定義
    Dim intIchi As Integer
    Dim strPath As String
    Dim vntpos As Variant
    Dim vntfolderpathcontainer As Variant
    Dim vntfolderpathcontainer2 As Variant
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")    'インスタンスの作成
    
    For Each objFile In objFSO.GetFolder(strPath).Files
        vntpos = InStrRev(objFile.Path, "\")　　　　’ファイルパス検索
        vntfolderpathcontainer = Left(objFile.Path, vntpos - 1)　　　　’フォルダパス切り出し
        vntpos = InStrRev(vntfolderpathcontainer, "\")　　　　’フォルダパス検索
        vntfolderpathcontainer2 = Mid(vntfolderpathcontainer, vntpos + 1)　　　　’フォルダ切り出し
        Worksheets("ファイル一覧").Cells(intIchi, 1) = objFSO.GetBaseName(objFile.Path)    '拡張子なしのファイル名
        Worksheets("ファイル一覧").Cells(intIchi, 2) = objFile.DateCreated    'ファイル作成日
        Worksheets("ファイル一覧").Cells(intIchi, 3) = objFile.DateLastModified    'ファイル更新日
        Worksheets("ファイル一覧").Cells(intIchi, 4) = ""    'コメント
        Worksheets("ファイル一覧").Hyperlinks.Add Anchor:=Cells(intIchi, 5), Address:=objFile.Path, TextToDisplay:=objFile.Name    'ファイル名ハイパーリンク
        Worksheets("ファイル一覧").Hyperlinks.Add Anchor:=Cells(intIchi, 6), Address:=strPath, TextToDisplay:=vntfolderpathcontainer2   'フォルダ名ハイパーリンク
        intIchi = intIchi + 1
    Next
    
    For Each objsubFolder In objFSO.GetFolder(strPath).SubFolders
        Call ファイル名取得(objsubFolder.Path, intIchi)
    Next
    
    Set objFSO = Nothing
    Set objsubFolder = Nothing
    Set objFile = Nothing
End Sub

Sub 空欄削除()
    Dim ListLastRow As Long
    Dim DeleteRows As Range
    Dim ws As Worksheet
    Dim i As Long


    Set ws = Worksheets("ファイル一覧")    '対象シート
    ListLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row    'A列を見て最終行を取得


    For i = 2 To ListLastRow    '2行目から探査
        If IsEmpty(ws.Cells(i, 1)) Then    'Rangeに削除対象行を格納
            If DeleteRows Is Nothing Then
                Set DeleteRows = ws.Rows(i).EntireRow
            Else
                Set DeleteRows = Union(DeleteRows, ws.Rows(i).EntireRow)
            End If
        End If
    Next


    If Not DeleteRows Is Nothing Then DeleteRows.Delete    '削除対象行が1つでもあれば行削除を実施

End Sub

Sub 連番挿入()
    Dim ListLastRow As Long
    Dim i As Long
    Dim number As Long
    Dim ws As Worksheet
    
    Columns("A").Insert
    number = 1
    Set ws = Worksheets("ファイル一覧")
    
    ListLastRow = ws.Range("B2").End(xlDown).Row
    
    For i = 2 To ListLastRow
        Cells(i, 1) = number
        number = number + 1
    Next
End Sub