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

    [Outlook VBA]最小化起動時にApplication.Startupイベントが発生しない。…

    Outlook起動時、すべてのアドインが読み込まれた後に発生するApp…

  2. Office関連

    [VBA]DataObjectを使ったクリップボード操作が上手くいかない場合の対処法

    VBAマクロからクリップボードを操作する場合、定番となっているのがDa…

  3. アイコン一覧

    Office 2013 アイコン一覧(O)

    ・Office 2013 アイコン一覧 NUM…

  4. Office アドイン

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

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

  5. Office関連

    スライド内容を自動的に機械翻訳するPowerPointマクロ

    前回の記事で紹介した各スライドに配置されたオートシェイプからテキストを…

  6. Office関連

    オデッセイ コミュニケーションズ主催のWord活用無料セミナーに参加しました。

    Club Microsoft会員限定、オデッセイ コミュニケーションズ…

コメント

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

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

Time limit is exhausted. Please reload CAPTCHA.

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

Translate

最近の記事

アーカイブ

PAGE TOP