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


WS上の画像の上にshapeを書き加えて、画像ファイルとして保存（その３）＋おまけEMF→BMPファイル変換

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

＜追記＞
セルに対して実行すると真っ黒なBitmapが生成され、あれ？動作しない．．．
実は、着色してない（透明色）セルに黒文字の場合、黒バックに黒文字がPlayEnhMetaFileされ、
真っ黒な画像が生成されるのでした。2010/Windows7では動かなくなったのかと、結構悩まされました。
安直には、hdcをSetPixelV等で事前に白で塗っておけば良いでしょう。 


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

'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
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 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

'==============================================================
'API関数の宣言
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

Const PICTYPE_ENHMETAFILE = 4

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
Const CF_ENHMETAFILE = 14
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long

Private Sub clipEmf2bmp()
  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 pic As StdPicture 'Pictureプロパティのデータ型
  
  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
  'Excelで図の挿入で貼り付けると元画像より縮小される。
	'→これは元画像の解像度dpi設定を反映させて表示されるためらしい
　'72dpiの画像のとき、ポイント=1/72と合致するため、計算上のサイズと、エクセルの図の
　'プロパティで表示される寸法（cm単位）が合致する。指定が無ければ96dpiと見なされる。
  With mh
     emfWidth = .rclBounds.Right - .rclBounds.Left
     emfHeight = .rclBounds.Bottom - .rclBounds.Top
  End With
  hdcDesktop = GetDC(0)
  hdc = CreateCompatibleDC(hdcDesktop)
'    hbmp = CreateCompatibleBitmap(hdc, emfWidth, emfHeight) これでは白黒画像
'    http://hpcgi1.nifty.com/MADIA/VBBBS/wwwlng.cgi?print+200504/05040072.txt
  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
  Dim hDIB As Long
  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)
  Set pic = GetPictureObject(hbmp)
  SavePicture pic, "C:\Test.bmp"
  SelectObject hdc, hbmpOld
  DeleteObject hbmp
  DeleteDC hdc
  DeleteEnhMetaFile hEmf ' 必要か不明
End Sub


'====================================================
' HBITMAPからPictureオブジェクトを作成する関数
'引数はBitMapのハンドル
Private Function GetPictureObject(ByVal hbmp As Long) As Object
 
    Dim iid As GUID     'Globally Unique Identifier型の変数iid
    Dim pd As PICTDESC  'Picture Descriptor構造体型の変数pd
    'ビットマップのハンドルが0なら、終了
    If hbmp = 0 Then Exit Function
    'GUID型構造体iidのメンバを設定
    With iid
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    'Picture Descriptor構造体を設定
    With pd
        .cbSizeofstruct = Len(pd)   'PICTDESC structureのサイズ
        .picType = PICTYPE_BITMAP   'pictureのタイプ（PICTYPE列挙体より）
        .hbitmap = hbmp             'ビットマップのハンドル
    End With
    'PICDESC構造体に設定した情報を元にピクチャーオブジェクトを作成。
    'OleCreatePictureIndirect(udtPICTDESC, udtGUID, True, NewPic)
    OleCreatePictureIndirect pd, iid, 1, GetPictureObject
 
End Function

'おまけ　emfファイルを、bmpに変換する
'bmpinfo生成時、PlayEnhMetaFileのためのRECT設定時にemfWidth,emfHeightに大きな値を与えてやると、高画素化できます。
Private Sub emf2bmp()
  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 pic As StdPicture 'Pictureプロパティのデータ型
  
  strFileName = "c:\saveEmfTest.emf"
    '拡張メタファイルのオープン
   hEmf = GetEnhMetaFile(strFileName)
   'ヘッダの取得
  GetEnhMetaFileHeader hEmf, Len(mh), mh
  With mh
     '単位はpixcel
     emfWidth = .rclBounds.Right - .rclBounds.Left
     emfHeight = .rclBounds.Bottom - .rclBounds.Top
     '.rclFrame.Right - .rclFrame.Leftが画像のプロパティでサイズとして表示される寸法である
     '下記計算の結果は、論理サイズと一緒になる
'      emfWidth = (.rclFrame.Right - .rclFrame.Left) * (96 / 25.4) / 100
'      emfHeight = (.rclFrame.Bottom - .rclFrame.Top) * (96 / 25.4) / 100
   End With
   hdcDesktop = GetDC(0)
   hdc = CreateCompatibleDC(hdcDesktop)
'    hbmp = CreateCompatibleBitmap(hdc, emfWidth, emfHeight) これでは白黒画像
'    http://hpcgi1.nifty.com/MADIA/VBBBS/wwwlng.cgi?print+200504/05040072.txt
  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
  Dim hDIB As Long
  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)
  Set pic = GetPictureObject(hbmp)
  SavePicture pic, "C:\Test.bmp"
  SelectObject hdc, hbmpOld
  DeleteDC hdc
  DeleteEnhMetaFile hEmf
End Sub