大分前に書いた回答用のコードが出てきたので、記事として残しておきます。
バイナリファイルを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形式の方が扱いやすいように思います。


















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