フォルダ、サブフォルダ内のWordのプロパティ情報を一括抽出する

必要に迫られたのでEcxelのマクロ（WordPropという名前）を書きました。Excelファイルの保存されているフォルダ内の、全てのWordファイルについて、フォルダの階層をたどってプロパティ情報を一括で抽出します。

作成にあたり、「情報系大学にいる人の備忘録」http://d.hatena.ne.jp/the-otakky/さんと、「T’sWare」http://www.tsware.jp/tips/tips_478.htmさんの記事を参考にしました。ありがとうございます。

100人以上の学生から、レポートをファイルで集めるような場合に重宝します。いちいちWordの起動と終了が繰り返されるので時間は掛かりますが、手作業よりはよほどマシです。

同時に印刷もしたい場合は、コメントを外してください。

Sub WordProp()
    Dim msg As String
    Dim filePath As String

    filePath = Application.ActiveWorkbook.path

    msg = "「" + filePath + "」以下に保存されているWordファイルからプロパティ情報を抽出します。"
    MsgBox msg
    Application.ScreenUpdating = False

    Worksheets("Sheet1").Select
    Range("A1:IV65536").Clear
    Range("A1").Value = "パス"
    Range("B1").Value = "ファイル名"
    Range("C1").Value = "作成者"
    Range("D1").Value = "リビジョン"
    Range("E1").Value = "作成日時"
    Range("F1").Value = "前回保存日時"
    Range("G1").Value = "総編集時間"
    Range("H1").Value = "ページ数"
    Range("I1").Value = "文字数"
    Range("J1").Value = "行数"
    Range("K1").Value = "段落数"
    Range("L1").Value = "バイト数"

    SearchDoc filePath, 2
End Sub

Function SearchDoc(path As String, row As Integer) As Integer
    Dim fso As Object
    Dim folder As Object
    Dim subfolder As Object
    Dim file As Object
    Dim ext As String
    Dim wordApp As Object
    Dim wordDoc As Object
    Dim waitTime As Variant

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(path)

    For Each subfolder In folder.SubFolders
        row = SearchDoc(subfolder.path, row)
    Next subfolder

    Set wordApp = CreateObject("word.application")
    wordApp.Visible = True
    For Each file In folder.Files
          ext = LCase(fso.GetExtensionName(file.Name))
          If ext = "doc" Or ext = "docx" Then
              Set wordDoc = wordApp.Documents.Open(file.path, ReadOnly:=True)
              wordDoc.Repaginate

              Range("A" & row).Value = path
              Range("B" & row).Value = file.Name
              Range("C" & row).Value = wordDoc.BuiltinDocumentProperties("Author")
              Range("D" & row).Value = wordDoc.BuiltinDocumentProperties("Revision number")
              Range("E" & row).Value = Str(wordDoc.BuiltinDocumentProperties("Creation date"))
              Range("F" & row).Value = Str(wordDoc.BuiltinDocumentProperties("Last save time"))
              Range("G" & row).Value = wordDoc.BuiltinDocumentProperties("Total editing time")
              Range("H" & row).Value = wordDoc.BuiltinDocumentProperties("Number of pages")
              Range("I" & row).Value = wordDoc.BuiltinDocumentProperties("Number of characters")
              Range("J" & row).Value = wordDoc.BuiltinDocumentProperties("Number of lines")
              Range("K" & row).Value = wordDoc.BuiltinDocumentProperties("Number of paragraphs")
              Range("L" & row).Value = wordDoc.BuiltinDocumentProperties(22)
              row = row + 1

              '印刷も実行したい場合はコメントを外す
              'wordDoc.PrintOut Copies:=1

              wordDoc.Close SaveChanges:=False
              Set wordDoc = Nothing
          End If
    Next file

    wordApp.Quit SaveChanges:=False

    Set wordApp = Nothing
    Set fso = Nothing
    SearchDoc = row
End Function

Excelファイルは下記となりますが、動作は保証しません。[表示]-[マクロ]-[マクロの表示]で、WordPropを[実行]します。

Wordのプロパティ（xlsmファイル）