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関連

    オフライン版のOffice 2016 VBAリファレンスが公開されました。

    「ヘルプファイル版のOffice 2013開発者用リファレンスが公開さ…

  2. Office関連

    関数一覧(Excel 2013 Customer Preview)

    関数の挿入ダイアログから抽出したExcel 2013 Customer…

  3. Office関連

    PDFファイルにヘッダーとフッターを追加するVBAマクロ

    mougに“マクロで既存のPDFファイルのフッターを操作(追加)したい…

  4. Office関連

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

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

  5. アイコン一覧

    Office 2013 アイコン一覧(W)

    ・Office 2013 アイコン一覧 NUM…

  6. アイコン一覧

    Office 365アイコン(imageMso)一覧(K,L)

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

コメント

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

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

Time limit is exhausted. Please reload CAPTCHA.

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

Translate

最近の記事

アーカイブ

PAGE TOP