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

[Office]スケッチ機能で図形の線を手書き風に!前のページ

[Windows 10]切り取り&スケッチを起動するショートカット次のページ

関連記事

  1. Excel

    新しくなったMZ-Tools

    みなさんは「MZ-Tools」というツールをご存知でしょうか?…

  2. Office関連

    Office 2016関連資料のリンク

    Office 2016関連資料のリンクをメモしておきます。特に「O…

  3. Office関連

    [Word VBA]ルビ(ふりがな)ダイアログの操作に挑む

    2016/10/28 追記:改良版のマクロを書きました。…

  4. Office関連

    外部からOutlookのマクロを実行するマクロ

    外部からOutlookのマクロを実行するマクロ今回は外部からO…

  5. アイコン一覧

    Office 2013 アイコン一覧(N)

    ・Office 2013 アイコン一覧 NUM…

  6. Office関連

    「DQNネーム辞書」を更新しました。

    前のブログで公開していたIME 2010用の「DQNネーム辞書」を更新…

コメント

  • コメント (0)

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

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

Time limit is exhausted. Please reload CAPTCHA.

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

Translate

最近の記事

アーカイブ

PAGE TOP