VBAからGDI+を使う資料集
inet上の達人の方々から御教示いただいたコードを少しアレンジさせてもらっています（切り貼りとも言います）。
  1. ホーム
  2. EMF
  3. embededobjecttext


Excelのワークシートの埋め込みオブジェクトのファイルパスをアイコンから読む

QAサイトのお題から、Office Open XMLファイルの中味を覗いてみたところ、埋め込まれたオブジェクトのファイル本体は内部的な名前に改名されており、アイコンがemf形式で収納されていた。 このemfを昔MSのサイトでみつけたCのソースから生成したemf viewerで見てみたところ、パスの切れて表示されない部分も内部的には含まれている事が分かった。 emfというのはDCへの描画をAPIで行う手順をそのまま記述した様なものなので、上記のツールでemf recordを表示させてみると、EMR_EXTTEXTOUTWがテキスト表示部分であり、 その中にはテキストが含まれている事が期待できる。バイナリエディタで確認したところ、パスを示す文字列の断片が確認できた。
という訳で、昔どこかで見つけてきたBitmap取り出しの記事を参考に、テキスト取り出しにトライしてみた。


Private Type RECT
    Left    As Long
    Top     As Long
    Right   As Long
    Bottom  As Long
End Type
Private Type METAFILEPICT
        mm As Long
        xExt As Long
        yExt As Long
        hmf As Long
End Type
Private Type RECTL
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Private Type SIZEL
    cx As Long
    cy As Long
End Type

Public Type POINTL
        x As Long
        y As Long
End Type

Private Type ENHMETAHEADER
        iType As Long
        nSize As Long
        rclBounds As RECTL
        rclFrame As RECTL '0.01mm単位
        dSignature As Long
        nVersion As Long
        nBytes As Long
        nRecords As Long
        nHandles As Integer
        sReserved As Integer
        nDescription As Long
        offDescription As Long
        nPalEntries As Long
        szlDevice As SIZEL
        szlMillimeters As SIZEL
End Type

Type emr
        iType As Long
        nSize As Long
End Type

Type ENHMETARECORD
        iType As Long
        nSize As Long
        dParm(1) As Long
End Type

Type EMRSETSTRETCHBLTMODE
        pEmr As emr
        iMode As Long
End Type

Public Type emrtext
        ptlReference As POINTL
        nchars As Long 'Stringの文字数
        offString As Long 'これは所属するemfrecord先頭から文字列へのオフセット
        fOptions As Long
        rcl As RECT
        offDx As Long
        'ここにtextが存在する
End Type

'EMR_EXTTEXTOUTW Exampleの内容と合致する
Public Type EMREXTTEXTOUT
        pEmr As emr 'Type & Size
        rclBounds As RECT 'これはBounds:0x00.....values are not used.のlong4個分を便宜上表している？
        iGraphicsMode As Long
        exScale As Single    ' and not Double as in the winapi vb declaration!
        eyScale As Single    ' and not Double as in the winapi vb declaration!
        emrtext As emrtext
End Type

'====== 定数 ======
Private Const PICTYPE_BITMAP = 1        'pictdescに与えるpictureのタイプ
Private Const DIB_RGB_COLORS = 0&

Const PICTYPE_ENHMETAFILE = 4
Const CF_ENHMETAFILE = 14
Const BI_RGB = 0&

Const EMR_HEADER = 1
Const EMR_POLYBEZIER = 2
Const EMR_POLYGON = 3
Const EMR_POLYLINE = 4
Const EMR_POLYBEZIERTO = 5
Const EMR_POLYLINETO = 6
Const EMR_POLYPOLYLINE = 7
Const EMR_POLYPOLYGON = 8
Const EMR_SETWINDOWEXTEX = 9
Const EMR_SETWINDOWORGEX = 10
Const EMR_SETVIEWPORTEXTEX = 11
Const EMR_SETVIEWPORTORGEX = 12
Const EMR_SETBRUSHORGEX = 13
Const EMR_EOF = 14
Const EMR_SETPIXELV = 15
Const EMR_SETMAPPERFLAGS = 16
Const EMR_SETMAPMODE = 17
Const EMR_SETBKMODE = 18
Const EMR_SETPOLYFILLMODE = 19
Const EMR_SETROP2 = 20
Const EMR_SETSTRETCHBLTMODE = 21
Const EMR_SETTEXTALIGN = 22
Const EMR_SETCOLORADJUSTMENT = 23
Const EMR_SETTEXTCOLOR = 24
Const EMR_SETBKCOLOR = 25
Const EMR_OFFSETCLIPRGN = 26
Const EMR_MOVETOEX = 27
Const EMR_SETMETARGN = 28
Const EMR_EXCLUDECLIPRECT = 29
Const EMR_INTERSECTCLIPRECT = 30
Const EMR_SCALEVIEWPORTEXTEX = 31
Const EMR_SCALEWINDOWEXTEX = 32
Const EMR_SAVEDC = 33
Const EMR_RESTOREDC = 34
Const EMR_SETWORLDTRANSFORM = 35
Const EMR_MODIFYWORLDTRANSFORM = 36
Const EMR_SELECTOBJECT = 37
Const EMR_CREATEPEN = 38
Const EMR_CREATEBRUSHINDIRECT = 39
Const EMR_DELETEOBJECT = 40
Const EMR_ANGLEARC = 41
Const EMR_ELLIPSE = 42
Const EMR_RECTANGLE = 43
Const EMR_ROUNDRECT = 44
Const EMR_ARC = 45
Const EMR_CHORD = 46
Const EMR_PIE = 47
Const EMR_SELECTPALETTE = 48
Const EMR_CREATEPALETTE = 49
Const EMR_SETPALETTEENTRIES = 50
Const EMR_RESIZEPALETTE = 51
Const EMR_REALIZEPALETTE = 52
Const EMR_EXTFLOODFILL = 53
Const EMR_LINETO = 54
Const EMR_ARCTO = 55
Const EMR_POLYDRAW = 56
Const EMR_SETARCDIRECTION = 57
Const EMR_SETMITERLIMIT = 58
Const EMR_BEGINPATH = 59
Const EMR_ENDPATH = 60
Const EMR_CLOSEFIGURE = 61
Const EMR_FILLPATH = 62
Const EMR_STROKEANDFILLPATH = 63
Const EMR_STROKEPATH = 64
Const EMR_FLATTENPATH = 65
Const EMR_WIDENPATH = 66
Const EMR_SELECTCLIPPATH = 67
Const EMR_ABORTPATH = 68
Const EMR_GDICOMMENT = 70
Const EMR_FILLRGN = 71
Const EMR_FRAMERGN = 72
Const EMR_INVERTRGN = 73
Const EMR_PAINTRGN = 74
Const EMR_EXTSELECTCLIPRGN = 75
Const EMR_BITBLT = 76
Const EMR_STRETCHBLT = 77
Const EMR_MASKBLT = 78
Const EMR_PLGBLT = 79
Const EMR_SETDIBITSTODEVICE = 80
Const EMR_STRETCHDIBITS = 81
Const EMR_EXTCREATEFONTINDIRECTW = 82
Const EMR_EXTTEXTOUTA = 83
Const EMR_EXTTEXTOUTW = 84
Const EMR_POLYBEZIER16 = 85
Const EMR_POLYGON16 = 86
Const EMR_POLYLINE16 = 87
Const EMR_POLYBEZIERTO16 = 88
Const EMR_POLYLINETO16 = 89
Const EMR_POLYPOLYLINE16 = 90
Const EMR_POLYPOLYGON16 = 91
Const EMR_POLYDRAW16 = 92
Const EMR_CREATEMONOBRUSH = 93
Const EMR_CREATEDIBPATTERNBRUSHPT = 94
Const EMR_EXTCREATEPEN = 95
Const EMR_POLYTEXTOUTA = 96
Const EMR_POLYTEXTOUTW = 97
Const EMR_MIN = 1
Const EMR_MAX = 97

'==============================================================
'API関数の宣言
Private Declare Function GetActiveWindow Lib "user32.dll" () As Long
Private Declare Function GetLastError Lib "kernel32" () As Long

Private Declare Function OpenClipboard Lib "user32" (ByVal hWndNewOwner As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal uFormat As Long) As Long

Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function EnumEnhMetaFile Lib "gdi32" (ByVal hdc As Long, ByVal hemf As Long, ByVal lpEnhMetaFunc As Long, lpData As Any, lpRect As RECT) As Long
Private Declare Function PlayEnhMetaFileRecord Lib "gdi32" (ByVal hdc As Long, ByVal pHandles As Long, ByVal pRecord As Long, ByVal HandleNum As Long) As Long
Private Declare Function RtlMoveMemory Lib "kernel32" (ByVal pDest As Long, ByVal pSrc As Long, ByVal l As Long) As Long
Private Declare Function GetEnhMetaFileBits Lib "gdi32" (ByVal hemf As Long, ByVal cbBuffer As Long, lpbBuffer As Byte) As Long
Private Declare Function GetEnhMetaFile Lib "gdi32" Alias "GetEnhMetaFileA" (ByVal lpszMetaFile As String) As Long
Private Declare Function GetMetaFile Lib "gdi32" Alias "GetMetaFileA" (ByVal lpFileName As String) As Long
Private Declare Function GetMetaFileBitsEx Lib "gdi32" (ByVal hmf As Long, ByVal nSize As Long, lpvData As Any) As Long
Private Declare Function SetWinMetaFileBits Lib "gdi32" (ByVal cbBuffer As Long, lpbBuffer As Byte, ByVal hdcRef As Long, lpmfp As METAFILEPICT) As Long
Private Declare Function PlayEnhMetaFile Lib "gdi32" (ByVal hdc As Long, ByVal hemf As Long, lpRect As RECT) As Long
Private Declare Function SetWinMetaFileBitsByNull Lib "gdi32" Alias "SetWinMetaFileBits" (ByVal cbBuffer As Long, lpbBuffer As Byte, ByVal hdcRef As Long, lpmfp As Long) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hemf As Long) As Long
Private Declare Function GetEnhMetaFileHeader Lib "gdi32" (ByVal hemf As Long, ByVal MetaHeaderSize As Long, ByRef MetaHeader As ENHMETAHEADER) As Long

Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Dest As Any, ByRef Src As Any, ByVal Length As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, _
                        ByRef Source As Long, _
                        ByVal Length As Long)


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) '最終引数はCのNULL
  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)
        '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
  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<