大分前に書いた回答用のコードが出てきたので、記事として残しておきます。
バイナリファイルをBase64エンコードし、文字列としてブック内のカスタムXMLに格納、また格納したファイルを元の形式で取り出すExcelマクロです。
※ 下記コードはExcel 2007以上に対応しています。
Option Explicit Public Sub Sample1() FileToCustomXML ActiveWorkbook, "obj1", "C:\Test\Sample.pdf" FileToCustomXML ActiveWorkbook, "obj2", "C:\Test\Sample.png" MsgBox "処理が終了しました。", vbInformation + vbSystemModal End Sub Public Sub Sample2() CustomXMLToFile ActiveWorkbook, "obj1", "C:\Test\SampleR.pdf" CustomXMLToFile ActiveWorkbook, "obj2", "C:\Test\SampleR.png" MsgBox "処理が終了しました。", vbInformation + vbSystemModal End Sub Private Sub FileToCustomXML(ByRef TargetWorkbook As Workbook, _ ByVal id As String, _ ByVal FilePath As String) 'ファイルをBase64エンコードしてカスタムXMLに格納 Dim d As Object Dim elm As Object Const adTypeBinary As Long = 1 Const adReadAll As Long = -1 Const ns As String = "http://hoge.jp/base64/contents/" '適当な名前空間 If Len(Dir$(FilePath)) < 1& Then MsgBox "入力元ファイル[" & FilePath & "]が存在していません。" & vbCrLf & _ "処理を中止します。", vbExclamation + vbSystemModal Exit Sub End If If TargetWorkbook.CustomXMLParts.SelectByNamespace(ns & id).Count > 0& Then MsgBox TargetWorkbook.Name & "にはすでに[" & id & "]が存在しています。" & vbCrLf & _ "処理を中止します。", vbExclamation + vbSystemModal Exit Sub End If On Error Resume Next Set d = CreateObject("MSXML2.DOMDocument") Set elm = d.createElement("base64") elm.setAttribute "xmlns", ns & id '識別用ID付加 elm.DataType = "bin.base64" With CreateObject("ADODB.Stream") .Type = adTypeBinary .Open .LoadFromFile FilePath elm.nodeTypedValue = .Read(adReadAll) .Close End With d.appendChild elm TargetWorkbook.CustomXMLParts.Add d.XML If Err.Number <> 0 Then MsgBox "エラーが発生しました。" & vbCrLf & _ "エラー内容:" & Err.Description, vbCritical + vbSystemModal End If On Error GoTo 0 End Sub Private Sub CustomXMLToFile(ByVal TargetWorkbook As Workbook, _ ByVal id As String, _ ByVal FilePath As String) 'ファイルが格納されたカスタムXMLからBase64デコードしてファイルを出力 Dim d As Object Const adTypeBinary As Long = 1 Const ns As String = "http://hoge.jp/base64/contents/" '適当な名前空間 If Len(Dir$(FilePath)) > 0& Then MsgBox "出力先ファイル[" & FilePath & "]がすでに存在しています。" & vbCrLf & _ "処理を中止します。", vbExclamation + vbSystemModal Exit Sub End If If TargetWorkbook.CustomXMLParts.SelectByNamespace(ns & id).Count < 1& Then MsgBox TargetWorkbook.Name & "には[" & id & "]が存在していません。" & vbCrLf & _ "処理を中止します。", vbExclamation + vbSystemModal Exit Sub End If On Error Resume Next Set d = CreateObject("MSXML2.DOMDocument") With CreateObject("ADODB.Stream") .Type = adTypeBinary .Open d.LoadXML TargetWorkbook.CustomXMLParts.SelectByNamespace(ns & id)(1).XML .Write d.FirstChild.nodeTypedValue .SaveToFile FilePath .Close End With If Err.Number <> 0 Then MsgBox "エラーが発生しました。" & vbCrLf & _ "エラー内容:" & Err.Description, vbCritical + vbSystemModal End If On Error GoTo 0 End Sub
ファイルをブックに埋め込む方法として、OLE オブジェクトを利用する方法もありますが、個人的には汎用的なBase64形式の方が扱いやすいように思います。
この記事へのコメントはありません。