Office関連

[Office VBA]カスタムXMLを使って設定情報などをドキュメントに保存する方法

Twitterで、@akashi_keirinさんの下記ツイートを見かけました。

なるほど。
設定等何らかの情報をファイルに持たせておきたい状況は多々あります。
Excelでは“隠しシート”がよく使われますが、他のアプリケーションだと確かに難しいかもしれません。

そこで私がオススメしたいのは「カスタムXML」です。

この機能はOffice 2007で追加されたもので、早い話が“ファイル内にXMLとして任意の情報を保存できる機能”です。

下記がカスタムXMLを使って情報を読み書きする簡単なコードで、実際に動きを見た方がイメージしやすいかと思います。

PowerPoint用のコードですが、Presentationオブジェクトの部分をWordのDocumentオブジェクトやExcelのWorkbookオブジェクトに変更すれば、他のOfficeアプリケーションでも実行可能です。

'※ 下記はPowerPoint用コード
Option Explicit

Private Const ns As String = "http://mynamespace/CustomProperties" '名前空間

Public Sub Sample()
'カスタムプロパティとして値を保存
  SaveCustomProperty ActivePresentation, ns, "CompanyName", "株式会社KA-NET"
End Sub

Public Sub Sample2()
'保存されたカスタムプロパティを読み込み
  Debug.Print LoadCustomProperty(ActivePresentation, ns, "CompanyName")
End Sub

Public Sub Sample3()
'カスタムプロパティを削除
  DeleteCustomProperty ActivePresentation, ns, "CompanyName"
End Sub

Public Sub Sample4()
'カスタムXMLを削除
  DeleteCustomXMLPart ActivePresentation, ns
End Sub

Private Sub SaveCustomProperty(ByVal doc As Object, _
                               ByVal ns As String, _
                               ByVal property_name As String, _
                               ByVal property_value As String)
'カスタムプロパティ設定
  Dim parts As Office.CustomXMLParts
  Dim part As Office.CustomXMLPart
  Dim root As Office.CustomXMLNode
  Dim target As Office.CustomXMLNode
  Dim target_attr As Office.CustomXMLNode
  Dim child As Object 'IXMLDOMElement
  Dim attr_id As Object 'IXMLDOMAttribute
  Dim attr_val As Object 'IXMLDOMAttribute
  Dim d As Object
  
  Set parts = doc.CustomXMLParts.SelectByNamespace(ns)
  If parts.Count < 1 Then
    Set part = InitCustomXMLParts(doc, ns)
  Else
    Set part = parts.Item(1)
  End If
  
  Set root = part.DocumentElement
  Set target = root.SelectSingleNode("//CustomProperty[@id='" & property_name & "']")
  If target Is Nothing Then
    'CustomProperty要素
    'id属性:property_name
    'value属性:property_value
    Set d = CreateObject("MSXML2.DOMDocument.6.0")
    Set child = d.createElement("CustomProperty")
    Set attr_id = d.createAttribute("id")
    attr_id.NodeValue = property_name
    child.Attributes.setNamedItem attr_id
    Set attr_val = d.createAttribute("value")
    attr_val.NodeValue = property_value
    child.Attributes.setNamedItem attr_val
    d.appendChild child
    root.AppendChildSubtree d.XML
  Else
    For Each target_attr In target.Attributes
      If target_attr.BaseName = "value" Then
        target_attr.NodeValue = property_value
        Exit For
      End If
    Next
  End If
  'If Not root Is Nothing Then Debug.Print root.XML '確認用
End Sub

Private Function LoadCustomProperty(ByVal doc As Object, _
                                    ByVal ns As String, _
                                    ByVal property_name As String) As String
'カスタムプロパティ読込
  Dim parts As Office.CustomXMLParts
  Dim root As Office.CustomXMLNode
  Dim target As Office.CustomXMLNode
  Dim target_attr As Office.CustomXMLNode
  
  Set parts = doc.CustomXMLParts.SelectByNamespace(ns)
  If parts.Count > 0 Then
    Set root = parts.Item(1).DocumentElement
    Set target = root.SelectSingleNode("//CustomProperty[@id='" & property_name & "']")
    If Not target Is Nothing Then
      For Each target_attr In target.Attributes
        If target_attr.BaseName = "value" Then LoadCustomProperty = target_attr.NodeValue
      Next
    End If
  End If
End Function

Private Sub DeleteCustomProperty(ByVal doc As Object, _
                                 ByVal ns As String, _
                                 ByVal property_name As String)
'カスタムプロパティ削除
  Dim parts As Office.CustomXMLParts
  Dim root As Office.CustomXMLNode
  Dim target As Office.CustomXMLNode
  
  Set parts = doc.CustomXMLParts.SelectByNamespace(ns)
  If parts.Count > 0 Then
    Set root = parts.Item(1).DocumentElement
    Set target = root.SelectSingleNode("//CustomProperty[@id='" & property_name & "']")
    If Not target Is Nothing Then target.Delete
  End If
  'If Not root Is Nothing Then Debug.Print root.XML '確認用
End Sub

Private Function InitCustomXMLParts(ByVal doc As Object, _
                                    ByVal ns As String) As Office.CustomXMLPart
'カスタムXML初期化
  Dim d As Object, root As Object
  
  Set d = CreateObject("MSXML2.DOMDocument.6.0")
  Set root = d.createElement("CustomProperties")
  root.setAttribute "xmlns", ns
  d.appendChild root
  Set InitCustomXMLParts = doc.CustomXMLParts.Add(d.XML)
End Function

Private Sub DeleteCustomXMLPart(ByVal doc As Object, _
                                ByVal ns As String)
'カスタムXML削除
  Dim parts As Office.CustomXMLParts
  
  Set parts = doc.CustomXMLParts.SelectByNamespace(ns)
  If parts.Count > 0 Then parts.Item(1).Delete
End Sub

上記「Sample」を実行すると、下記のようなXMLがドキュメント内に保存されます。

<CustomProperties xmlns="http://mynamespace/CustomProperties">
  <CustomProperty xmlns="" id="CompanyName" value="株式会社KA-NET" />
</CustomProperties>

保存したファイルをZip解凍すると、「customXml」フォルダ内にXMLファイルとして保存されていることが確認できます。

保存されたXMLから値を読み込む場合は、「Sample2」のように「LoadCustomProperty」を使用します。

任意のファイルをドキュメントに埋め込む方法

また、下記記事で紹介しているような、ファイルをBase64エンコード・デコードする処理を組み込めば、任意のファイルをドキュメントに埋め込むこともできます。

Public Sub Sample5()
  SaveCustomProperty ActivePresentation, ns, "Sample.png", EncodeBase64("C:\Test\Sample.png")
End Sub

Public Sub Sample6()
  Dim b64 As String
  Const fn As String = "Sample.png"
  
  b64 = LoadCustomProperty(ActivePresentation, ns, fn)
  DecodeBase64 b64, "C:\Test\Picture\" & fn
End Sub
エンコードしたファイルを埋め込んだカスタムXMLの例
<CustomProperties xmlns="http://mynamespace/CustomProperties">
  <CustomProperty xmlns="" id="Sample.png" value="iVBORw0KGgoAAAANSUhEUgAAAIEAAABRCAIAAAB6/FIoAAAAAXNSR0IArs4c6QAAAARnQU1B&#xA;AACxjwv8YQUAAAAJcEhZcwAADsMAAA7DAcdvqGQAAASoSURBVHhe7ZvrYaswDEYzFwNlnkzD&#xA;MgxzrwwiwZJsS7agpNX51xY/9B3bgTR5BEEQBEEQBEEQBEEQBEEQBIE70/P5mucF+JezLK/n&#xA;hBcFpzBB9DR2xvIKC6cwPWHZY8gUth/mJ7YKnEjxY7hHlmV+Tp8V/5zx90DsBE/E/JdZOvSP&#xA;EmIjOCHnX3zNnV7vq//YPshz8lt/h0TfNKL9bARHB9ME92AJuA+TeaW/wmXY4HKO+3/FR4Ig&#xA;AA5//GOR9WU7MY8p2G98cWQT6zF5qQ6elYMDScAFZwvc9irue5Wk2wXstwFsoA382Q7bB6Np&#xA;XS4AjhpN9O8TJ2c7o+Qto5h3Xm1noc4OWHcnCoAAK+cNeeLQ5MnvIJqt2IrrKdfzMBK2gN9L&#xA;fI50w5VILyV4iOTLQZkNLaE1f6Fke81+DnhP522BB47wYX3ewz9u5A60VZEqWiXwfZ+wRsh6&#xA;6XPAJ9PrUgWOsSI/8P2kA+vyY8u3Jzs2lRO3wMp2C8sX/4EuB0YFRQeAIUcHB5cbUNHjgFbS&#xA;bFVxYEnSPC6BSbyFgQ4HPYVUHeijoEPbHNzVgNUBq0NXSDZIakGl6OKgo5tCZOvAuota4KPU&#xA;Cv5KidoBPOPR/LUh5NltjboiIY0MDs7ZBOnBF558WS5GwRoH4iO2/m0K0UGXhW4HdKwRA+s7&#xA;Dq23HEwD5LNjTeV3OAz5J2QHgoXWzDsdsE1gWqUrquA/QEDYUEPJQektjsJjRpWSA7 MFEqbS&#xA;AVWgbYYHjTr4D8oRdlg+8spPpNVv6nun7ECwUFukXQ7oCNVWmDteWgMWY1qNsFTxFweM+4wu&#xA;EpHu9DdqDqQZFFPqcUAzkvOpvrF5AJN/I8fn6qDn5OHUHUhzKKWbB6pxoFBQj2BlzUEYTNoE&#xA;gIsD8lmOQVoOxFmIdVgd0H7FFoUggVL0SFHemAMY1S/7nbYDgCchXGh1QDrVDb29s99OoezO&#xA;6MBcVgcqB1JN7FLjZGm4nsUVNwFwQwfqIYS68nJskz1TAek755sdiBaO15smS/uyJlOhauDb&#xA;HQC8vk8LEmu9VtKRnwIudzDEyx20sygfSRYH5Fq/yojb1LGrA8fV8sa0eDcEC1thhmJPKkxS&#xA;O6q7IyEjfSOQCIFUmt7BaC4ypFcs5v4OehckrReYyXuXlb5O2Qak0z3s3+sAIE0Zagcu24Au&#xA;ivfot3dQnLmKuoVytaOxcCp1/HIHvH1GsbPRWCh0FlmHo4OR9vdzAJQ3w0UOqga+wAEJsC8N&#xA;GsLOJQ4aBsZL/A4HgLgZLnDA9PMxnR0MTLYAmeCAZJZGZbr02t5hmXmpo+FlNtxBg+N/XG2f&#xA;NxCg0ZZn61EWk17oZXgsfVn3AL+72Pp+4vhGIMlWknF3MLpU7wKN0FYXE1BrP+wgraz9C7Gq&#xA;/+F9CewgUUuQPq9Sbezg4JeiPc1zWCug9bHCcFBEiLO6nNOHjPC6A4pEw0EF4VCBhNiqLn2w&#xA;M93HaeIMB1UkCyvpK2LpK9dS9Bv6KMNBA/mEqaNc/ztUtO0W7I+g99D16U7qIDZCEfwSgQTc&#xA;lndkv8MPvNgJlyO86oSFy6GnXRxHQRAEQRAEQRAEQRDcj8fjP8ue/AX4jXxKAAAAAElFTkSu&#xA;QmCC" />
</CustomProperties>

5年ほど前に書いた下記記事のコードと同様の処理ですね。
活用場面は多いのではないかと思います。

以上のように、カスタムXMLを使えば、ドキュメント内に自由に情報を持たせておくことができるようになります。
あまり使われていない、メジャーではない機能かもしれませんが、非常に便利な機能ですので、皆さんも是非ご活用ください!

関連記事

  1. Office アドイン

    [Office用アプリ]任意の場所にデータを入力する。

    ※ この情報はOffice 2013 カスタマー プレビュー版を元にし…

  2. Office アドイン

    [Office用アプリ]販売者ダッシュボードが日本語化されました。

    当ブログでも下記ページなどで紹介しているSeller Dashboar…

  3. Office関連

    PHPWordを使ってPHPからWordファイルを出力してみる。

    最近オトカドールやルミティアジュエルやらの記事ばかり書いていますが、今…

  4. アイコン一覧

    Office 2013 アイコン一覧(K,L)

    ・Office 2013 アイコン一覧 NUM…

  5. Office関連

    オフライン版のOffice 2016 VBAリファレンスが公開されました。

    「ヘルプファイル版のOffice 2013開発者用リファレンスが公開さ…

  6. Office関連

    [Office 2013]サインインを無効にする。(2)

    前回の記事では「SignInOptions」の値を変更してサインインを…

コメント

  • コメント (0)

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

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

Time limit is exhausted. Please reload CAPTCHA.

最近の記事

アーカイブ

RapidSSL_SEAL-90x50
PAGE TOP