Excel 埋め込みオブジェクトのファイル名取得

質問

Excelファイルに挿入＞オブジェクト＞ファイルから　・・・
で選択し、埋め込んだオブジェクトのファイル名をVBAで
取得する事はできますか？

実際には上記のように手動ではなく、
Application.Dialogs(xlDialogInsertObject).Show , " ", , True
でダイアログを表示し、ファイルを選択させています。

埋め込んだファイルがフォルダ階層が深かったりすると、
ファイル名まで表示されないので、ファイル名を取得して、
別のセルに入力するまでをVBAで処理をしたいと考えています。

既に埋め込まれているオブジェクトの名前を取得する、もしくは
ダイアログで選択されたファイルの名前を取得する、ということが
できるのであれば教えていただけますでしょうか？

回答No.2

mitarashi

#1です。元気を出して久しぶりにEMFをいじってみました。
絶対に文字数に収まらない構造体や、定数、API関数の宣言は載せてありません。好事家の方は、下記URL等から借用して下さい。
http://homepage2.nifty.com/nonnon/Win32Api/index.html
選択した埋め込みオブジェクトのパスを表示します。Win7Home(64bit)、xl2010(32bit)で試しています。
出来てみると簡単そうですが、数え切れない程Excelをハングアップさせた成果です（基礎が出来てない、下手くそとも言う）。適切な構造体を調べ、その中から目的のデータの位置を調べて取り出すのに苦労しました。

Sub getEmbededFilePath()
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 Sub
End If
'メタファイルの内容を取得
BufSize = GetEnhMetaFileBits(hSrcMetaFile, ByVal 0, ByVal 0)
ReDim SrcData(BufSize)
BufSize = GetEnhMetaFileBits(hSrcMetaFile, BufSize, SrcData(0))
If BufSize = 0 Then
MsgBox "GetEnhMetaFileBits failed!"
Exit Sub
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)
MoveMemory byteEmfText(0), SrcData(topEMREXTTEXTOUT + emfText.offString), emfText.nchars * 2
'StrPtr(extEmfText)やVarPtr(extEmfText)だとハングアップする
'byte配列を文字列に変換してくれる
extEmfText = byteEmfText
'合成したとき文字化けするので安直な対策。なおvbNullCharが入っているためではなさそう。
filePath = filePath & Application.WorksheetFunction.Clean(extEmfText)
i = i + 1
End If
SrcIdx = SrcIdx + RecordHeader.nSize
Loop
DeleteEnhMetaFile hSrcMetaFile
MsgBox filePath
End Sub

' メタファイルレコード列挙コールバック
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

回答No.1

mitarashi

埋め込みファイルのアイコンをクリックして、図としてコピー／ピクチャで、emf形式でクリップボードにコピーします。昔MSのサイトでみつけたEMFビュワーに貼り付けて確認すると、フルパスが表示されました。（画像参照）
EMF RECORDを確認すると、EMR_EXTTEXTOUTWというRECORDが６個ありますので、これが６段に分割されているパスに相当するのだと思います。これはバイナリエディタでも確認できました。後は、EMR_EXTTEXTOUTWを解読すれば可能でしょう。
http://msdn.microsoft.com/en-us/library/cc231081.aspx
元気のある方はやってみて下さい。
代替案としては、埋め込み自体をコードでやるのはいかがでしょうか。その際にパスを別セルに保存しておきます。
昔投稿した事がありますが、アイコン取得がムダに長いです。
http://okwave.jp/qa/q4353361.html

肝心なところを抜粋すると下記の通りです。ご参考まで。
Sub pasteFileObject(objFilePath As String, iconFilePath As String)
Dim FSO
Dim fileName As String

Set FSO = CreateObject("Scripting.FileSystemObject")
fileName = FSO.GetFileName(objFilePath)
ActiveSheet.OLEObjects.Add(fileName:=objFilePath, Link:=False, _
DisplayAsIcon:=True, IconFileName:=iconFilePath, _
IconIndex:=0, IconLabel:=fileName).Select
Set FSO = Nothing
End Sub