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ファイルに含まれる画像ファイルを抜き出したり、なんてこともできるかと思います。

Excel REST APIをPowerShellから呼び出す方法前のページ

PDFのしおり数を取得するVBAマクロ次のページ

関連記事

  1. Office関連

    続・Microsoft Edgeを操作するVBAマクロ(DOM編)

    以前VBAからMicrosoft Edgeを操作するマクロについて記事…

  2. Office関連

    SendKeysでWindowsキーを送信するVBAマクロ

    「VBA SendKeys Windowsキー」といったキーワード検索…

  3. Office関連

    Word 2013の「個人用テンプレート」はどこ?

    Word 2010では、から「個人用テンプレート」(カスタム テンプレ…

  4. Office関連

    セル内にあるブックマークをカウントするWordマクロ

    Twitterを眺めていたら下記ツイートを発見しました。【Wo…

  5. アイコン一覧

    Office 365アイコン(imageMso)一覧(X,Y,Z)

    Office 365のデスクトップ版Officeアプリケーション(Wo…

コメント

  • コメント (0)

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

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

Time limit is exhausted. Please reload CAPTCHA.

※本ページはプロモーションが含まれています。

Translate

最近の記事

アーカイブ

PAGE TOP