Excelシート上に貼り付けられたファイルの保存

質問

Excelシート上(A.xlsx)にさらにExcelファイル(B.xlsx)が貼り付けられています。
A.xlsxのシート上では、ExcelのアイコンとB.xlsxのファイル名が見えている状態です。

アイコンをクリックしてB.xlsxのファイルを開くことはできますが、そこから保存しようとすると、A.xlsxのファイル名で保存されようとします。
アイコンの右クリックでもExcelファイルとしての保存はできなさそうです。

このB.xlsxを、簡単にB.xlsxのファイル名で保存する方法はないでしょうか？
もちろん手で画面をみながら再入力すれば可能ですが、入力ミスや手間を省きたいのです。
Excelのバージョンは2010です。

回答No.1

mitarashi

以前に調べた事があるのですが、貼り付けたオブジェクトのファイル名は、アイコンの絵の上にしか保存されていない様でした。アイコンの絵はEnhanced Metafile (EMF) という形式なので、そこから取得出来ない事もないのですが、「簡単に」とは言い難いです。（一部好事家しか理解の出来ないVBAになりますので）
http://okwave.jp/qa/q8751602.html

試しにやってみたコードです。これだけでは動かず、構造体とか、Windows APIのDeclaration部とかが必要で、4000文字には収まりきれませんので、ご関心がある様なら必要な部分だけ抽出して別途投稿いたします。

埋め込んだファイルを選択してから実行します。例えばマクロ付きブックを埋め込んだ直後だと、当該マクロに参照設定した様な状態になっていて（VBEで確認できます）保存時に実行自エラーになりますので、Excelを一度終了させた後に実行する必要があります。Windows7Home(64bit),xl2010(32bit)で試しています。

Sub test()
Dim filePath As String

If TypeName(Selection) <> "OLEObject" Then Exit Sub
filePath = getEmbededFilePath
Selection.Verb Verb:=xlPrimary
ActiveWorkbook.SaveAs Filename:= _
filePath, FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
ActiveWindow.Close
End Sub

Function getEmbededFilePath() As String
Dim SrcData() As Byte '元のメタファイルの内容を格納するバッファ
Dim SrcIdx As Long 'メタファイルからデータを取り出す位置を示す
Dim hSrcMetaFile As Long '複製元メタファイルのハンドル
Dim BufSize As Long 'SrcDataに格納されたメタファイルのサイズ
Dim RecordHeader As emr 'メタファイルレコードのヘッダ
'EMR_EXTTEXTOUTWの個数だけ宣言する必要あり。使い回し不可。とりあえず大きめに宣言。
Dim emfTextRecord(10) As EMREXTTEXTOUT
Dim emfText As emrtext
Dim topEMREXTTEXTOUT As Long
Dim extEmfText As String
Dim byteEmfText() As Byte
Dim i As Long
Dim filePath As String

'複製元メタファイルをクリップボードから取得
Selection.Copy
If OpenClipboard(0) Then
hSrcMetaFile = GetClipboardData(CF_ENHMETAFILE)
hSrcMetaFile = CopyEnhMetaFile(hSrcMetaFile, vbNullString)
CloseClipboard
End If
If hSrcMetaFile = 0 Then
MsgBox "emf取得に失敗"
Exit Function ' 失敗
End If
'メタファイルの内容を取得
BufSize = GetEnhMetaFileBits(hSrcMetaFile, ByVal 0, ByVal 0) '最終引数はCのNULL
ReDim SrcData(BufSize)
BufSize = GetEnhMetaFileBits(hSrcMetaFile, BufSize, SrcData(0))
If BufSize = 0 Then
MsgBox "GetEnhMetaFileBits failed!"
Exit Function
End If
SrcIdx = 0
i = 0
Do While SrcIdx < BufSize
extEmfText = Space(255)
'レコードのヘッダを取得
MoveMemory RecordHeader, SrcData(SrcIdx), Len(RecordHeader)
If RecordHeader.iType = EMR_EXTTEXTOUTW Then 'レコードの場合
'EMR_EXTTEXTOUTWの内容を、構造体emfTextRecord(AS EMREXTTEXTOUT )に取り込む
MoveMemory emfTextRecord(i), SrcData(SrcIdx), RecordHeader.nSize
'文字のレコードの先頭位置を保存
topEMREXTTEXTOUT = SrcIdx
emfText = emfTextRecord(i).emrtext

ReDim byteEmfText(emfText.nchars * 2)
'EMREXTTEXTOUTの入れ子の構造体emrtextは、親構造体（EMF RECORD)の先頭からの文字列の位置を
'.Offstringとして保持している。
MoveMemory byteEmfText(0), SrcData(topEMREXTTEXTOUT + emfText.offString), emfText.nchars * 2
'StrPtr(extEmfText)やVarPtr(extEmfText)だとハングアップする

'byte配列から文字列への変換(VBAが勝手にやってくれる）
extEmfText = byteEmfText
'合成したとき文字化けするので安直な対策。なおvbNullCharが入って居るためではなさそう。
filePath = filePath & Application.WorksheetFunction.Clean(extEmfText)
i = i + 1
End If
SrcIdx = SrcIdx + RecordHeader.nSize
Loop
DeleteEnhMetaFile hSrcMetaFile
getEmbededFilePath = filePath
End Function

' メタファイルレコード列挙コールバック
Public Function EnumFunc(ByVal hdc As Long, ByVal pHandles As Long, ByVal pRecord As Long, _
ByVal HandleNum As Long, ByVal pData As Long) As Long
Dim eh As ENHMETARECORD 'EMR 'レコードのヘッダ

'レコードのヘッダをehに格納
RtlMoveMemory VarPtr(eh), pRecord, Len(eh)
EnumFunc = 1
End Function

お礼

詳しい御説明ありがとうございます。

ファイル名が見えているので簡単にできてもよさそうですが、なかなか難しそうですね。