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
まだ回答がついていません
会員登録して回答してみよう