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


WS上の画像の上にshapeを書き加えて、画像ファイルとして保存（その４）

okwaveで、ワークシート上に貼り付けた画像の上にshapeを書き加えて、画像ファイルとして保存したいというお題が出され、
PrtScして、グラフィックソフトで保存するという至極真っ当なsolutionで閉じられてしまいましたが、
VBAでやる方法はないかと模索してみました。
その４．メモリ上にビットマップを作成し、EMFを描画後、BMPで保存する方法。BMPの作成をより原始的？な方法でやってみました。


'====== 構造体 ======

'Globally Unique Identifier構造体
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
'Picture Descriptor構造体 MSDN(Eng)参照
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
Private Type BITMAPFILEHEADER   '14 bytes
       bfType       As String * 2
       bfSize       As Long
       bfReserved1  As Integer
       bfReserved2  As Integer
       bfOffBits    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

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

'==============================================================
'API関数の宣言
Private Declare Function GetActiveWindow Lib "user32.dll" () As Long
Private Declare Function GetLastError Lib "kernel32" () 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 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 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 OleCreatePictureIndirect Lib "olepro32" _
        (lpPictDesc As PICTDESC, riid As GUID, _
        ByVal fOwn As Long, lplpvObj As Object) 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 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 GetDIBits Lib "gdi32" ( _
    ByVal aHDC As Long, _
    ByVal hbitmap As Long, _
    ByVal nStartScan As Long, _
    ByVal nNumScans As Long, _
    lpBits As Any, lpBI As BITMAPINFO, _
    ByVal wUsage As Long) As Long

Private Sub clipEmf2bmp4()
  Dim hbmp As Long
  Dim hbmpOld As Long
  Dim hdc As Long, hdcDesktop As Long
  Dim hEmf As Long '拡張メタファイルのハンドル
  Dim r As RECT '描画する領域
  Dim strFileName As String
  Dim mh As ENHMETAHEADER '取得結果のメタファイルヘッダ
  Dim emfWidth As Long, emfHeight As Long
  Dim bmpInfo As BITMAPINFO
  Dim hDIB As Long
  Dim lngRet As Long
  Dim BmpBits() As Byte
  Dim fnum As Long
  Dim bmifh As BITMAPFILEHEADER
  
  Selection.Copy
  If OpenClipboard(0) Then
    hEmf = GetClipboardData(CF_ENHMETAFILE)
    ' ハンドルを複製してから使用する
    hEmf = CopyEnhMetaFile(hEmf, vbNullString)
    CloseClipboard
  End If
  If hEmf = 0 Then
    MsgBox "emf取得に失敗"
    Exit Sub  ' 失敗
  End If
   'ヘッダの取得
  GetEnhMetaFileHeader hEmf, Len(mh), mh
  With mh
     emfWidth = .rclBounds.Right - .rclBounds.Left
     emfHeight = .rclBounds.Bottom - .rclBounds.Top
  End With
  hdcDesktop = GetDC(0)
  hdc = CreateCompatibleDC(hdcDesktop)
  With bmpInfo.bmiHeader '構造体初期化
    .biSize = 40
    .biWidth = emfWidth
    .biHeight = emfHeight
    .biPlanes = 1
    .biBitCount = 24 '２４ビット
    .biCompression = 0 'BI_RGB
    .biSizeImage = 0 'BI_RGBの時は０
    .biClrUsed = 0
  End With
  
  hbmp = CreateDIBSection(hdc, bmpInfo, DIB_RGB_COLORS, 0, 0, 0) 'DIB作成
  hbmpOld = SelectObject(hdc, hbmp)
  '描画領域の設定
  r.Left = 0
  r.Top = 0
  r.Right = emfWidth
  r.Bottom = emfHeight
  
  '拡張メタファイルの描画
  Call PlayEnhMetaFile(hdc, hEmf, r)

  'http://sanryu.net/acc/tips/tips288.htm
  'ビットマップの取得 最初サイズ0&指定で、biSizeImageにサイズを取得している
  lngRet = GetDIBits(hdc, hbmp, 0, bmpInfo.bmiHeader.biHeight, ByVal 0&, bmpInfo, DIB_RGB_COLORS)
  ReDim BmpBits(bmpInfo.bmiHeader.biSizeImage - 1)
  lngRet = GetDIBits(hdc, hbmp, 0, bmpInfo.bmiHeader.biHeight, BmpBits(0), bmpInfo, DIB_RGB_COLORS)
  
  'ビットマップファイル名
  strFileName = "c:\test.bmp"
  fnum = FreeFile
  'ビットマップファイル保存
  Open strFileName For Binary As #fnum
  With bmifh
      .bfType = "BM"
      .bfReserved1 = 0
      .bfReserved2 = 0
      .bfSize = Len(bmifh) + Len(bmpInfo) + UBound(BmpBits) + 1
      .bfOffBits = Len(bmifh) + Len(bmpInfo)
  End With
  Put #fnum, , bmifh       'ビットマップファイルヘッダ
  Put #fnum, , bmpInfo        'ビットマップ情報
  Put #fnum, , BmpBits    '画像データ
  Close #fnum
  
  SelectObject hdc, hbmpOld
  DeleteObject hbmp
  DeleteDC hdc
  DeleteEnhMetaFile hEmf ' 必要か不明
End Sub
'http://wisdom.sakura.ne.jp/system/winapi/win32/win118.html