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

Question

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

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

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

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

Comments

[y_waiwai]

どこのどういうプロパティからどんなコメントを削除するんでしょうか。
問題が見えません

[gaint]

ファイルを右クリックしたらプロパティという欄が表示されるかと思いますがそこの詳細タブのコメントの欄に書かれている文字列を取得したいです。
わかりにくく申し訳ございません。

Answer 1

GetObjectで取得したオブジェクトのBuiltinDocumentPropertiesを参照すれば、コメントが取得できます。
GetObjectであれば、ファイルの種類に依存せず、コメントが取得可能になります。
GetObject実行時、その対象ファイルがexcel関連のファイルなら(.xlsx等)オープンされ、その内容が画面に
表示されます。
この表示を抑止するために、Application.ScreenUpdating = Falseを実行しておきます。

又「また、拡張子、ファイル名がtmp、temp、bk、bakを含むファイルを大文字または小文字どちらの場合でも除外できる方法も知りたいです。」については、IsJogaiのファンクションプロシージャを作成しました。
除外対象ならtrueを返します。したがって、結果がfalseの場合、処理をすれば良いことになります。

Option Explicit

Sub サブフォルダ含むファイルデータ取得()
    Dim intIchi As Integer
    Dim strPath As String

     intIchi = 2          '開始行

     strPath = Worksheets("保管場所").Range("B3").Value          'ファイルパス取得

    Sheets("ファイル一覧").Select        'シート選択
    Application.ScreenUpdating = False      '画面表示抑止

    Call ファイル名取得(strPath, intIchi)
    Call 空欄削除
    Call 連番挿入
    Application.ScreenUpdating = True       '画面表示抑止解除
End Sub

Sub ファイル名取得(strPath As String, intIchi As Integer)
    Dim objFSO As Object, objFile As Object, objsubFolder    'オブジェクト定義
'Dim intIchi As Integer     '2重定義なので削除
'Dim strPath As String      '2重定義なので削除
    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
        If IsJogai(objFile.name) = False Then
            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) = getComment(objFile.path)    'コメント
            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
        End If
    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

Private Function getComment(ByVal path As String) As String
    Dim obj As Object
    On Error GoTo ERR99
    Set obj = GetObject(path)
    getComment = obj.BuiltinDocumentProperties("Comments")
    obj.Close False
ERR99:
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

Answer 2

BuiltinDocumentPropertiesを使ってやるのはどうかと思うのですが使ってやるのであれば

    Dim objBook As Workbook
    Set objBook = Workbooks.Open("パス")
    Debug.Print objBook.BuiltinDocumentProperties.Item("Comments").Value

で、Excelであればコメントは取れるみたいですね。
Wordに関しても、同様な形でコメントは取れるようです。

    Dim objWordApp As Object
    Dim objDocument As Object
    Set objWordApp = CreateObject("Word.Application")
    Set objDocument = objWordApp.Documents.Open("パス")
    Debug.Print objDocument.BuiltinDocumentProperties.Item("Comments").Value
    objDocument.Close
    objWordApp.Quit

PowerPointとかでも取れるんじゃないかなあと思いますが
同じようにファイルを開く必要があるので処理は遅くなりそうですね。

あと一部のファイルを除くという所ですがVBScript.RegExpを使えば一応そんなにif文は使わなくていいですね。

    Dim objRegExp As Object
    Set objRegExp = CreateObject("VBScript.RegExp")
    objRegExp.Pattern = "tmp|temp|bk|bak"
    
    If Not objRegExp.test(LCase("ファイル名")) Then
        ' ここに入ってくるのが処理対象
    End If

VBScript.RegExpを使わないなら、配列でArray("tmp","temp","bk","bak")として
ループでLikeで処理して判定でも出来そうですね。