下記記事でも書いていますが、xlsxやdocxといった、OOXML形式のOfficeファイルをZIP解凍すると、中にあるXMLファイルから様々な情報を取得することができます。

2015.10.07

「Excel VBAの神様 ボクの人生を変えてくれた人」(大村あつし著)レビュー

※ 下記レビューはあくまでも個人的な感想です。 2015年9月29日発売の「Excel VBAの神様 ボクの人生を変えてくれた人」(秀和システム出版)をさっそく購入してきました。 作者はOffice(VBA)界隈では知らない人は...

ファイル数が少なければ特に問題は無いのですが、ファイル数が多いとき、いちいち解凍してファイルを探してテキストエディタで開いて…というのは少々面倒臭く感じます。

そこで、ドラッグ＆ドロップするだけでファイルの情報を取得できるよう、スクリプトを書くことにしました。

Option Explicit

Dim Args

Set Args = WScript.Arguments
If Args.Count < 1 Then
  MsgBox "Officeファイルを当スクリプトファイルにドラッグ＆ドロップしてください。", vbExclamation + vbSystemModal
  WScript.Quit
End If
GetOpenXMLInfo Args(0)

Private Sub GetOpenXMLInfo(ByVal TargetFilePath)
  Dim TmpFolderName
  Dim TmpFolderPath
  Dim TmpFileName
  Dim TmpFilePath
  Dim DpFolderPath
  Dim AppFilePath
  Dim CoreFilePath
  Dim AppVersion
  Dim dc_creator
  Dim cp_lastModifiedBy
  Dim dcterms_created
  Dim dcterms_modified
  Dim d1, d2
  Const dp = "docProps"
  Const app = "app.xml"
  Const core = "core.xml"
    
  '作業用フォルダ作成・作業用ファイル(zip)コピー
  TmpFolderName = Replace(Now(), "/", "")
  TmpFolderName = Replace(TmpFolderName, ":", "")
  TmpFolderName = Replace(TmpFolderName, " ", "")
  TmpFolderName = "tmp_" & TmpFolderName
  With CreateObject("Scripting.FileSystemObject")
    TmpFolderPath = AddPathSeparator(.GetFile(TargetFilePath).ParentFolder.Path) & _
                    TmpFolderName
    If .FolderExists(TmpFolderPath) = True Then
      MsgBox "作業用フォルダがすでに存在しています。" & vbNewLine & _
             "処理を中止します。", vbExclamation + vbSystemModal
      Exit Sub
    End If
    .CreateFolder TmpFolderPath
    TmpFileName = .GetBaseName(.GetFile(TargetFilePath)) & ".zip"
    TmpFilePath = AddPathSeparator(TmpFolderPath) & TmpFileName
    .CopyFile TargetFilePath, TmpFilePath, True
  End With
  
  'zipファイルから[docProps]フォルダをコピー
  With CreateObject("Shell.Application")
    .Namespace(TmpFolderPath).CopyHere .Namespace(TmpFilePath).Items.Item(dp)
  End With
  
  'xmlファイルのパス取得
  With CreateObject("Scripting.FileSystemObject")
    DpFolderPath = AddPathSeparator(TmpFolderPath) & dp
    If .FolderExists(DpFolderPath) = False Then
      MsgBox "[docProps]フォルダが見つかりませんでした。" & vbNewLine & _
             "処理を中止します。", vbExclamation + vbSystemModal
      DelFolder TmpFolderPath
      Exit Sub
    End If
    AppFilePath = AddPathSeparator(DpFolderPath) & app
    CoreFilePath = AddPathSeparator(DpFolderPath) & core
    If (.FileExists(AppFilePath) = False) Or _
       (.FileExists(CoreFilePath) = False) Then
      MsgBox "XMLファイルが見つかりませんでした。" & vbNewLine & _
             "処理を中止します。", vbExclamation + vbSystemModal
      DelFolder TmpFolderPath
      Exit Sub
    End If
  End With
  
  'xmlファイルから値を取得
  With CreateObject("MSXML2.DOMDocument")
    .async = False
    If .Load(AppFilePath) = False Then
      MsgBox app & "ファイルの読み込みに失敗しました。" & vbNewLine & _
             "処理を中止します。", vbExclamation + vbSystemModal
      DelFolder TmpFolderPath
      Exit Sub
    End If
    On Error Resume Next
    AppVersion = .SelectSingleNode("/Properties/AppVersion").Text
    On Error GoTo 0
    If .Load(CoreFilePath) = False Then
      MsgBox core & "ファイルの読み込みに失敗しました。" & vbNewLine & _
             "処理を中止します。", vbExclamation + vbSystemModal
      DelFolder TmpFolderPath
      Exit Sub
    End If
    On Error Resume Next
    dc_creator = .SelectSingleNode("/cp:coreProperties/dc:creator").Text
    cp_lastModifiedBy = .SelectSingleNode("/cp:coreProperties/cp:lastModifiedBy").Text
    dcterms_created = .SelectSingleNode("/cp:coreProperties/dcterms:created").Text
    d1 = Replace(dcterms_created, "T", " ")
    d1 = Replace(d1, "Z", "")
    dcterms_modified = .SelectSingleNode("/cp:coreProperties/dcterms:modified").Text
    d2 = Replace(dcterms_modified, "T", " ")
    d2 = Replace(d2, "Z", "")
    On Error GoTo 0
  End With
  DelFolder TmpFolderPath
  
  '結果表示
  MsgBox "File:" & TargetFilePath & vbNewLine & _
         "AppVersion:" & AppVersion & vbNewLine & _
         "dc:creator:" & dc_creator & vbNewLine & _
         "cp:lastModifiedBy:" & cp_lastModifiedBy & vbNewLine & _
         "dcterms:created:" & dcterms_created & "(" & DateAdd("h", 9, CDate(d1)) & ")" & vbNewLine & _
         "dcterms:modified:" & dcterms_modified & "(" & DateAdd("h", 9, CDate(d2)) & ")", vbInformation + vbSystemModal
End Sub

Private Sub DelFolder(ByVal TargetFolderPath)
  With CreateObject("Scripting.FileSystemObject")
    .DeleteFolder TargetFolderPath, True
  End With
End Sub

Private Function AddPathSeparator(ByVal s)
  If Right(s, 1) <> ChrW(92) Then s = s & ChrW(92)
  AddPathSeparator = s
End Function

上記コードをvbsファイルとして保存した後、Officeファイルをドラッグ＆ドロップすると、ファイルを作成したアプリケーションのバージョンや作成者、更新日時といった情報がメッセージボックスで表示されます。

ファイルの情報が分かったからといってどうということもないのですが、上記コードを応用すると、Officeファイルに含まれる画像ファイルを抜き出したり、なんてこともできるかと思います。