Excel VBAメモオブジェクトの挿入で埋め込んだ圧縮ファイルを指定した場所に保存してみる

2017/07/12VBA

せっかくExcelに他のExcelファイルを埋め込めるんだから、他のファイルをうまく埋め込んで1つのファイルにできないもんかなぁって思ってネットに聞いてたら…あるんだねぇ。

ポイントはこんなとこ。

オブジェクトの挿入でシートに圧縮ファイルを埋め込む
OLEObjectsから圧縮ファイルのOLEObjectを取得する
※オブジェクトそのものの名前を変更するExcelの操作がわからないので、今回はシートに1つだけオブジェクトがあるという前提にした
OLEObjectをコピーする
コピーしたら一時フォルダに圧縮ファイルが一時的に保存されるので、そいつをコピーする

まずは圧縮ファイルの内容はこんな感じ。

こいつらを圧縮ファイルにする。

んで、準備したExcelはこんな感じ。
さっき作った圧縮ファイルをオブジェクトの挿入でシート上に追加しただけ。

ちなみに、オブジェクトの挿入でシート上に圧縮ファイルを追加する手順はこんな感じ。

挿入タブのオブジェクトをクリックする。
“オブジェクトの挿入"って画面が表示されるので、"新規作成"ってタブをクリックする。

オブジェクトの種類ってとこで"Package"って項目をクリックしたら、画面右下の"OK"ボタンをクリックする。
※何でか"Package"って項目が2つあるけど、どっちでもいいみたい。
“パッケージの作成"って画面が表示されてファイルを選んでくれって言ってくるので、ファイルを選択する。

ファイルを選択したらこんな感じ。
んで、画面右下にある"次へ"ボタンをクリックする。
パッケージの作成って画面が表示されてラベルってのを教えてくれって言ってくるけどデフォルトでファイル名が表示される。
今回は特に影響しない項目なので、そのまま画面の右下の"完了"ボタンをクリックする。

選んだファイルがシート上に表示されたらおしまい。

で、コードはこんな感じ。

Private Sub Method()

    ' 変数を定義する
    Dim objObject As OLEObject              ' シート上の圧縮ファイルのオブジェクト
    Dim objFile As Object                   ' ファイルシステムオブジェクト
    Dim strTemporaryFolderPath As String    ' 一時フォルダーのパス
    Dim strFileName As String               ' 圧縮ファイルの名前
    Dim strSourcePath As String             ' 圧縮ファイルのコピー元のフルパス
    Dim strTargetPath As String             ' 圧縮ファイルのコピー先のフルパス
    
    ' 変数を初期化する
    Set objObject = Nothing
    Set objFile = CreateObject("Scripting.FileSystemObject")
    strTemporaryFolderPath = objFile.GetSpecialFolder(2) ' GetSpecialFolder()の引数2は一時フォルダーを意味している
    strFileName = "Data.zip" ' ここは今回固定の名前にする
    strSourcePath = strTemporaryFolderPath & "\" & strFileName
    strTargetPath = "D:\Output" & "\" & strFileName
    
    '
    On Error GoTo MethodEnd
    
        ' オブジェクト(圧縮ファイル)を取得する
        Set objObject = MainSheet.OLEObjects(1)
        If objObject Is Nothing Then
            GoTo MethodEnd
        End If
        
        ' オブジェクトをコピーすることでTempフォルダーにファイルが一時保存される
        ' ※たまにファイル名のあとに連番(ex."Data (2).zip"とか)になるので注意！
        objObject.Select
        objObject.Copy
        
        ' 一時フォルダーにある圧縮ファイルをコピーする
        ' ※フォルダーがなかったりファイルが既にある場合は失敗するので
        '   事前のチェックとかファイルを削除しておく必要があるので注意！
        objFile.CopyFile strSourcePath, strTargetPath
    
MethodEnd:

    ' オブジェクトを開放する
    If Not objObject Is Nothing Then
        Set objObject = Nothing
    End If
    If Not objFile Is Nothing Then
        Set objFile = Nothing
    End If

End Sub

実行したらこんな感じ。
今回保存する場所は"D:¥Output"ってフォルダーにしたんだけど、指定した場所に圧縮ファイルが保存されとる。

ちなみに、一時フォルダーにはこんな感じで圧縮ファイルが一時的に保存される。
保存される場所はシステムドライブがCの場合"C:¥User¥(アカウント名)¥AppData¥Local¥Temp"になる。
んで、Excelを終了すれば一時フォルダーからファイルは削除されるはず。
※AppDataフォルダーは隠しフォルダーなので設定の変更が必要。