Office関連

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

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

関連記事

  1. アイコン一覧

    Office 365アイコン(imageMso)一覧(M)

    Office 365のデスクトップ版Officeアプリケーション(Wo…

  2. Office関連

    ヘッドレス ChromeとSeleniumBasicでWebページ全体のスクリーンショットを撮る方法…

    先日、ヘッドレス ChromeでWebページ全体のスクリーンショットを…

  3. Office関連

    文書が互換モードかどうかを判定するWordマクロ

    古いバージョンのWordで作成された文書を開くと、タイトル バーに「互…

  4. Office アドイン

    [Office用アプリ]Apps for Office サミット!で登壇しました。

    21日(土)に開催されたOffice 用アプリの勉強会「Apps fo…

  5. Office関連

    Office 2016のコントロールIDリストが公開されました。

    昨年の秋にリリースされたOffice 2016。そのコントロールI…

  6. アイコン一覧

    Office 365アイコン(imageMso)一覧(X,Y,Z)

    Office 365のデスクトップ版Officeアプリケーション(Wo…

コメント

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

  1. この記事へのトラックバックはありません。

Time limit is exhausted. Please reload CAPTCHA.

最近の記事

アーカイブ

RapidSSL_SEAL-90x50
PAGE TOP