Office関連

Officeファイルから作成者などのプロパティを取得するVBScript

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

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

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

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ファイルをドラッグ&ドロップすると、ファイルを作成したアプリケーションのバージョンや作成者、更新日時といった情報がメッセージボックスで表示されます。

GetOpenXMLInfo_01

GetOpenXMLInfo_02

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

関連記事

  1. Office関連

    パスワードが設定されたファイルを開くPowerPointマクロ

    WordやExcelと違って、PowerPointの場合はOpenメソ…

  2. VBScript

    WordPressのバックアップを取ってローカル環境で動かす方法(3)

    「WordPressのバックアップを取ってローカル環境で動かす方法(1…

  3. Office アドイン

    Office 365でVisio JavaScript APIsを試してみました。

    昨年末にVisio Onlineの機能をJavaScriptで拡張する…

  4. Office関連

    アラビア文字かどうかを判別するWordマクロ

    以前mougの質問用に書いたコードが出てきたので、一部修正しました。…

  5. Office関連

    7-Zipで圧縮・解凍を行うVBAマクロ

    「7-Zip VBA」といったキーワード検索でのアクセスがありました。…

コメント

  • コメント (0)

  • トラックバックは利用できません。

  1. この記事へのコメントはありません。

Time limit is exhausted. Please reload CAPTCHA.

最近の記事

アーカイブ

RapidSSL_SEAL-90x50
PAGE TOP