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


emfを読む習作、emfからbitmapを取り出しBMP形式で保存

シート上に貼り付けた画像（単独）のBitmapを直接取得してBMP形式で保存します
これまでは、メモリDCに再描画後出力していました
最初に見つかったEMRSTRETCHDIBITSからBitmapを取得して保存します。
貼り付けた画像ファイルはjpegでも通用しました。クリップボードから取得したemfの情報（前項参照）は元がbmpでも、jpegでも同様でしたので、
クリップボードに複写した時点でbmpになってしまうのかもしれません。

追伸：構造体等がサイトの何処にも載っていない事に気付いて追加しました。 


Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type PICTDESC
    cbSizeofstruct As Long
    picType As Long
    hbitmap As Long
    hpal As Long
    unused_wmf_yExt As Long
End Type
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

Type BITMAPINFOHEADER
    biSize As Long              'ヘッダーのサイズ
    biWidth As Long             '幅(ピクセル単位)
    biHeight As Long            '高さ(ピクセル単位)
    biPlanes As Integer         '常に１
    biBitCount As Integer       '1ピクセルあたりのカラービット数
    biCompression As Long       '圧縮方法
    biSizeImage As Long         'ピクセルデータの全バイト数
    biXPelsPerMeter As Long     '0または水平解像度
    biYPelsPerMeter As Long     '0または垂直解像度
    biClrUsed As Long           '通常は0
    biClrImportant As Long      '通常は0
End Type
Type RGBQUAD
    rgbBlue As Byte             '青の濃さ
    rgbGreen As Byte            '緑の濃さ
    rgbRed As Byte              '赤の濃さ
    rgbReserved As Byte         '未使用(常に0)
End Type

Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
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

Type EMRSTRETCHDIBITS
        pEmr As emr
        rclBounds As RECTL
        xDest As Long
        yDest As Long
        xSrc As Long
        ySrc As Long
        cxSrc As Long
        cySrc As Long
        offBmiSrc As Long
        cbBmiSrc As Long
        offBitsSrc As Long
        cbBitsSrc As Long
        iUsageSrc As Long
        dwRop As Long
        cxDest As Long
        cyDest As Long
End Type

Type BITMAPFILEHEADER
        bfType As String * 2 '手直し
        bfSize As Long
        bfReserved1 As Integer
        bfReserved2 As Integer
        bfOffBits As Long
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 CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hgdiobj As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32.dll" (ByVal hdc As Long, pbmi As BITMAPINFO, ByVal iUsage As Long, ppvBits As Long, ByVal hSection As Long, ByVal dwOffset As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" (lpPictDesc As PICTDESC, riid As GUID, ByVal fOwn As Long, lplpvObj As Object) 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)
'As Any だとポインタになってしまうため、ByVal .. as longで実アドレスを渡せる様にしてみた
Private Declare Sub MoveMemory2 Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByVal Source As Long, ByVal Length As Long)

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

' シートの画像をBMP書きだし
Sub getBitmapInfo()
  Dim SrcData() As Byte '元のメタファイルの内容を格納するバッファ
  Dim hSrcMetaFile As Long '複製元メタファイルのハンドル
  Dim r As RECT '描画する領域
  Dim BufSize As Long 'SrcDataに格納されたメタファイルの内容のサイズ
  Dim SrcIdx As Long, DestIdx As Long
  Dim RecordHeader As emr 'メタファイルレコードのヘッダ
  Dim strechDibRecord As EMRSTRETCHDIBITS
  Dim hFileMetaFile As Long
  Dim bmInfo As BITMAPINFO
  Dim offsetBmInfo As Long
  Dim offsetBmSrc As Long
  Dim topEMRSTRECHEDIBITS As Long
  Dim bitmapData() As Byte
  Dim strFileName As String
  Dim fnum As Long
  Dim bmifh As BITMAPFILEHEADER
      
  'ビットマップファイル名
  strFileName = "c:\test.bmp"
  '複製元メタファイルをクリップボードから取得
  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) '最終引数はＣのNULL
  ReDim SrcData(BufSize)
  BufSize = GetEnhMetaFileBits(hSrcMetaFile, BufSize, SrcData(0))
  If BufSize = 0 Then
    MsgBox "GetEnhMetaFileBits failed!"
    Exit Sub
  End If
  SrcIdx = 0
  DestIdx = 0
  Do While SrcIdx < BufSize
      'レコードのヘッダを取得
      MoveMemory RecordHeader, SrcData(SrcIdx), Len(RecordHeader)
      If RecordHeader.iType = EMR_STRETCHDIBITS Then 'BitMapレコードの場合
          'BITMAP情報を取得
          MoveMemory strechDibRecord, SrcData(SrcIdx), Len(strechDibRecord)
          topEMRSTRECHEDIBITS = SrcIdx
          Exit Do
      End If
      SrcIdx = SrcIdx + RecordHeader.nSize
  Loop
  DeleteEnhMetaFile hSrcMetaFile
  With strechDibRecord
    'BitmpaHeaderを読む
    MoveMemory bmInfo, SrcData(topEMRSTRECHEDIBITS + .offBmiSrc), .cbBmiSrc 'LenB(bmInfo)
    'Bitmapを読む
    ReDim bitmapData(.cbBitsSrc)
    MoveMemory bitmapData(0), SrcData(topEMRSTRECHEDIBITS + .offBitsSrc), .cbBitsSrc
    'ヘッダー情報を付け足してファイル出力する
    fnum = FreeFile
    'ビットマップファイル保存
    Open strFileName For Binary As #fnum
    With bmifh
        .bfType = "BM" 'bfType は string * 2 で宣言する必要あり
        .bfReserved1 = 0
        .bfReserved2 = 0
        .bfSize = Len(bmifh) + Len(bmInfo) + UBound(bitmapData) + 1
        .bfOffBits = Len(bmifh) + Len(bmInfo)
    End With
    Put #fnum, , bmifh       'ビットマップファイルヘッダ
    Put #fnum, , bmInfo        'ビットマップ情報
    Put #fnum, , bitmapData   '画像データ
    Close #fnum
  End With
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)
'  Debug.Print getEMRtype(eh.iType)
  EnumFunc = 1
End Function