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 2016でUTF-8のCSVファイルがサポートされるようになりました。

    Office 2016の10月の機能更新によって、ExcelでUTF-…

  2. Office アドイン

    [Officeアドイン]Word JavaScript APIの機能紹介

    Office Dev Center - Changelogを見ると分か…

  3. Office関連

    指定したフォルダ内の画像ファイルを一括挿入するPowerPointマクロ

    大量の画像ファイルを1枚/1スライドで挿入する必要があり、…

  4. Excel

    Excel REST APIをPowerShellから呼び出す方法

    以前Excel REST APIをVBAから呼び出す方法を紹介しました…

  5. アイコン一覧

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

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

コメント

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

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

Time limit is exhausted. Please reload CAPTCHA.

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

Translate

最近の記事

アーカイブ

PAGE TOP