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

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

2019.07.12

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

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

#ExcelVBA の場合、処理に必要な設定の類は隠しシートでも作ってそのシートに持たせておけばよい。
しかし、他の #VBA ではその方法が使えない
この問題を、なるべく簡単に解決したいねえ。

— チン☆テクラ (@akashi_keirin) 2019年7月9日

なるほど。
設定等何らかの情報をファイルに持たせておきたい状況は多々あります。
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エンコード・デコードする処理を組み込めば、任意のファイルをドキュメントに埋め込むこともできます。

2014.05.30

ファイルをBase64エンコード・デコードするVBAマクロ

以前書いたファイルのBase64エンコード・デコード処理を行うVBAマクロをメモとして残しておきます。 [vb]Option Explicit Public Sub Sample() Sheet1.TextBox1.Text = Encode...

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年ほど前に書いた下記記事のコードと同様の処理ですね。
活用場面は多いのではないかと思います。

2014.11.21

ファイルをブックに埋め込むExcelマクロ

大分前に書いた回答用のコードが出てきたので、記事として残しておきます。バイナリファイルをBase64エンコードし、文字列としてブック内のカスタムXMLに格納、また格納したファイルを元の形式で取り出すExcelマクロです。 ※ 下記コードはExce...

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