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形式の方が扱いやすいように思います。

テーブルの罫線色情報を列挙するPowerPointマクロ前のページ

[リボン・カスタマイズ]splitButton要素の内容を動的に変更する。次のページ

関連記事

  1. Office関連

    ExcelのWebクエリからのアクセス情報

    mougに面白い質問がありました。・Querytables.a…

  2. Office Scripts

    Visual Studio Code for Office Scriptsの紹介

    インストール要らずで利用できるWeb用Visual Studio Co…

  3. Office関連

    受信メールに対して自動的に返信するOutlookマクロ

    「Outlook VBA 自動返信」といったキーワード検索でのアクセス…

  4. Office アドイン

    OfficeJS Snippet Explorerを使って新しいOffice アドインを体験する。

    前回の記事と打って変わって元のOffice アドインの記事に戻ります(…

  5. Office アドイン

    [Office用アプリ]コピー&ペースト用マニフェストファイル

    Office 用アプリを作るとき、過去に作ったアプリのマニフェストファ…

  6. Office アドイン

    [Office用アプリ]Seller Dashboardの不満点

    当ブログでも散々取り上げていますが、ストア登録の申請含めて、Offic…

コメント

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

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

Time limit is exhausted. Please reload CAPTCHA.

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

Translate

最近の記事

アーカイブ

PAGE TOP