VBAからGDI+を使う資料集
inet上の達人の方々から御教示いただいたコードを少しアレンジさせてもらっています(切り貼りとも言います)。
  1. ホーム
  2. EMF
  3.  Userformに描画、BMP貼付、保存


 Userformに描画、BMP貼付、emf形式で保存、他

白bmpファイルを生成し、Userform-Image-Pictureに読み込んでハンドルを取得し、互換hdcを設定
PictureにBMPファイルを読み込んで描画したり、Win32APIで描画した後、emfファイルで保存する習作。


'Windows API Function Declarations
'Does the clipboard contain a bitmap/metafile?
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
'Open the clipboard to read
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
'Get a pointer to the bitmap/metafile
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
'Close the clipboard
Private Declare Function CloseClipboard Lib "user32" () As Long
'Convert the handle into an OLE IPicture interface.
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 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 GetEnhMetaFile Lib "gdi32" Alias "GetEnhMetaFileA" (ByVal lpszMetaFile As String) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long 'The API format types we're interested in
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function PlayEnhMetaFile Lib "gdi32" (ByVal hdc As Long, ByVal hemf As Long, lpRect As RECT) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateHatchBrush Lib "gdi32" (ByVal nIndex As Long, ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function Ellipse Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pbmi As BITMAPINFO, ByVal iUsage As Long, ByVal ppvBits As Long, ByVal hSection As Long, ByVal dwOffset As Long) As Long
Private Declare Function SetBkColor Lib "gdi32.dll" (ByVal hdc As Long, ByVal crColor As Long) 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 Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal pLastPoint As Long) As Long

Private Const LR_LOADFROMFILE = &H10
Private Const WHITE_BRUSH = 0
Private Const CF_BITMAP = 2
Private Const CF_PALETTE = 9
Private Const CF_ENHMETAFILE = 14
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4
Private Const TRANSPARENT = 1
Private Const NULL_PEN = 8
Private Const HS_DIAGCROSS = 5
Private Const LF_FACESIZE = 32
Private Const BLACK_PEN = 7
Private Const vbsolid = 0
Private Const SRCCOPY = &HCC0020
Private Const DIB_RGB_COLORS = 0
Private Const DIB_PAL_COLORS = 1
Private Const DIB_PAL_INDICES = 2
Private Const PS_SOLID = 0              '実線
Private Const PS_DASH = 1               '破線
Private Const PS_DOT = 2                '点線
Private Const PS_DASHDOT = 3            '一点鎖線
Private Const PS_DASHDOTDOT = 4         '二点鎖線
Private Const PS_NULL = 5               '非表示
Private Const PS_INSIDEFRAME = 6        '塗りつぶし

Private Enum ePicTypeConst
    ePicTypeNone = 0
    ePicTypeBitmap = 1
    ePicTypeMetafile = 2
    ePicTypeIcon = 3
    ePicTypeEMetafile = 4
End Enum
Private Enum NGdiObhectType
    GdiObjPen = 1
    GdiObjBrush = 2
    GdiObjDC = 3
    GdiObjMetaDC = 4
    GdiObjPalette = 5
    GdiObjFont = 6
    GdiObjBitmap = 7
    GdiObjRegion = 8
    GdiObjMetafile = 9
    GdiObjMemDC = 10
    GdiObjExtPen = 11
    GdiObjEnhMetaDC = 12
    GdiObjEnhMetafile = 13
End Enum
'Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
'Declare a UDT to store the bitmap information
Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As Long
    hpal As Long
End Type
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom 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 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 Type TPictDesc
    'この構造体のサイズです。
    cbSizeofStruct As Long
    'ピクチャーのタイプを指定。
    picType As ePicTypeConst
    'イメージのハンドル。
    hImage As Long
    'ビットマップの場合は、パレットのハンドル。
    'メタファイルの場合は、幅。
    Option1 As Long
    'メタファイルの場合は、高さ。
    Option2 As Long
End Type
Private Type TGUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(1 To 8) As Byte
End Type

Type LOGFONT
        lfHeight As Long
        lfWidth As Long
        lfEscapement As Long
        lfOrientation As Long
        lfWeight As Long
        lfItalic As Byte
        lfUnderline As Byte
        lfStrikeOut As Byte
        lfCharSet As Byte
        lfOutPrecision As Byte
        lfClipPrecision As Byte
        lfQuality As Byte
        lfPitchAndFamily As Byte
        lfFaceName(LF_FACESIZE) As Byte
End Type

Private Type BITMAP         'BITMAP構造体
        bmType As Long
        bmWidth As Long
        bmHeight As Long
        bmWidthBytes As Long
        bmPlanes As Integer
        bmBitsPixel As Integer
        bmBits 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

Private Type BITMAPINFOHEADER   '40 bytes
        biSize As Long
        biWidth As Long
        biHeight As Long
        biPlanes As Integer
        biBitCount As Integer
        biCompression As Long
        biSizeImage As Long
        biXPelsPerMeter As Long
        biYPelsPerMeter As Long
        biClrUsed As Long
        biClrImportant As Long
End Type

Private Type BITMAPINFO
        bmiHeader As BITMAPINFOHEADER
        'bmiColors As RGBQUAD   '16ビット(65536色)以上の場合はカラーパレット不要
End Type

Sub drawEmfOnUserform()
  Dim myImage As Image
  Dim hBmp As Long, hdc As Long
  Dim hComDC As Long
  Dim ret As Long
  Dim r As RECT
  Dim hemf As Long
  Dim mh As ENHMETAHEADER '取得結果のメタファイルヘッダ
  Dim readEMFsize As SIZEL
  Dim hemf2 As Long
  'Bitmap File 読み込み用
  Dim lnghDC As Long, lngBMP As Long
  
  Dim bmp As BITMAP
  Dim imageWidth As Long, imageHeight As Long
  
  imageWidth = 240: imageHeight = 240
  
  '========= Clipboardからemfを取得 =========
  'Selection.Copy
  'If OpenClipboard(0) Then
  '  hemf = GetClipboardData(CF_ENHMETAFILE)
  '  ' ハンドルを複製してから使用する
  '  hemf = CopyEnhMetaFile(hemf, vbNullString)
  '  CloseClipboard
  'End If
  '
  '======= ファイルから読み込んで表示できる =======
  'hemf = GetEnhMetaFile("c:\test.emf")
  '
  'If hemf = 0 Then
  '  MsgBox "emf取得に失敗"
  '  Exit Sub
  'End If
  '   ヘッダの取得
  'GetEnhMetaFileHeader hemf, Len(mh), mh
  'With mh
  '  readEMFsize.cx = .rclBounds.Right - .rclBounds.Left
  '  readEMFsize.cy = .rclBounds.Bottom - .rclBounds.Top
  'End With

  UserForm1.Show vbModeless
  Set myImage = UserForm1.Image1
  
  '======= Userformのサイズ設定 =======
  'Excel Userformのサイズはpoint単位
  '1 pt = 1/72 in. (= 25.4/72 mm = 0.352 777 7... mm)
  'Pixcelサイズは、通常96dpi = 25.4/96 = 0.264583333mm/pixel
  '100pixels -> 100 / 96 inch -> 72 * 100 /96 point
  '240pixels -> 240 * 72 / 96 = 180pt
  With UserForm1
    .Width = (imageWidth * 72 / 96) + 4.5 '220pixels
    .Height = (imageHeight * 72 / 96) + 24
  End With
  With UserForm1.Image1
    .Height = UserForm1.InsideHeight
    .Width = UserForm1.InsideWidth
    .Top = 0
    .Left = 0
  End With
  myImage.Picture = Nothing
  myImage.PictureAlignment = fmPictureAlignmentTopLeft
  myImage.PictureSizeMode = fmPictureSizeModeClip
  
  'Pictureのハンドル取得のため、白のbmpをロードする。
  'Pictureに読み込み用の白Bmp作成
  '寸法は目的サイズよりも大きい分には問題なし
  makeWhiteBmpFile imageWidth, imageHeight, "c:\white.bmp"
  
  myImage.Picture = LoadPicture("c:\white.bmp")
  hBmp = myImage.Picture.handle
  hdc = GetDC(0)
  hComDC = CreateCompatibleDC(hdc)
  lnghDC = CreateCompatibleDC(hdc)
  
  ret = ReleaseDC(0, hdc)
  ret = SelectObject(hComDC, hBmp)
  
  'Bitmapの描画
  lngBMP = LoadImage(0, "c:\test96.bmp", IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE)
  'bmpのサイズ取得
  GetObject lngBMP, Len(bmp), bmp

  SelectObject lnghDC, lngBMP
  BitBlt hComDC, 20, 20, bmp.bmWidth + 20, bmp.bmHeight + 20, lnghDC, 0, 0, SRCCOPY
  
  DeleteDC lnghDC
  DeleteObject lngBMP
  ret = ReleaseDC(0, hdc)
  
  'hdcに、emfを読み込んで描画(サイズ指定で、一部に)
  'r.Top = 10
  'r.Left = 10
  'r.Bottom = UserForm1.Image1.Height * 96 / 72
  'r.Right = UserForm1.Image1.Width * 96 / 72
'  hemf = GetEnhMetaFile("c:\temp.emf")
  'Call PlayEnhMetaFile(hComDC, hemf, r)
  
  '描画ルーチンを呼び出す
  DrawDC0 (hComDC)

  ret = DeleteDC(hComDC)
  
  'これでsaveできる。undoに使えそう。
  'SavePicture myImage.Picture, "C:\savepicture.emf"
  Set myImage = Nothing
End Sub

'Win32 api で描画
Private Sub DrawDC0(hdc&)
  'hDC上に描く
  Dim hPen&, hOldPen&, hBrush&, hOldBrush&
  Dim hBlackPen&
  
  hBlackPen = GetStockObject(BLACK_PEN)
  '背景を白で塗りつぶす
'  hPen = GetStockObject(NULL_PEN)
'  hBrush = GetStockObject(WHITE_BRUSH)
'  SelectObject hdc, hPen
'  SelectObject hdc, hBrush
  'Rectangle hdc, 0, 0, 148, 100
  '円
  hBrush = CreateSolidBrush(RGB(0, 128, 0))
  SelectObject hdc, hBlackPen
  hOldBrush = SelectObject(hdc, hBrush)
  Ellipse hdc, 10, 30, 45, 65
  DeleteObject SelectObject(hdc, hOldBrush)
  '四角
  hBrush = CreateSolidBrush(RGB(0, 0, 255))
  hOldBrush = SelectObject(hdc, hBrush)
  Rectangle hdc, 55, 30, 90, 65
  DeleteObject SelectObject(hdc, hOldBrush)
  '線
  hPen = CreatePen(vbsolid, 2, RGB(255, 0, 0))
  hOldPen = SelectObject(hdc, hPen)
  MoveToEx hdc, 100, 30, ByVal 0&
  LineTo hdc, 135, 65
  DeleteObject SelectObject(hdc, hOldPen)
End Sub

Private Sub makeWhiteBmpFile(bmpWidth As Long, bmpHeight As Long, fileName As String)
    Dim hdc         As Long
    Dim hmDC        As Long
    Dim bmi         As BITMAPINFO
    Dim hBmp        As Long
    Dim hPen        As Long
    Dim hBrush      As Long
    Dim oldBmp      As Long
    Dim oldPen      As Long
    Dim oldBrush    As Long
    Dim rt          As Long
    Dim BmpBits()   As Byte
    Dim fnum        As Long
    Dim bmifh       As BITMAPFILEHEADER
    
    hdc = GetDC(0&)
    hmDC = CreateCompatibleDC(hdc)
    With bmi.bmiHeader
        .biSize = 40
        .biWidth = bmpWidth
        .biHeight = bmpHeight
        .biPlanes = 1
        .biBitCount = 24
    End With
    hBmp = CreateDIBSection(hmDC, bmi, DIB_RGB_COLORS, 0, 0, 0)
    oldBmp = SelectObject(hmDC, hBmp)
    hPen = CreatePen(PS_DOT, 2, vbWhite)
    oldPen = SelectObject(hmDC, hPen)
    SetBkColor hmDC, vbWhite
    hBrush = GetStockObject(WHITE_BRUSH)
    oldBrush = SelectObject(hmDC, hBrush)
    Rectangle hmDC, 0, 0, bmpWidth, bmpHeight
    rt = GetDIBits(hmDC, hBmp, 0, bmpHeight, ByVal 0&, bmi, DIB_RGB_COLORS)
    ReDim BmpBits(bmi.bmiHeader.biSizeImage - 1)
    rt = GetDIBits(hmDC, hBmp, 0, bmpHeight, BmpBits(0), bmi, DIB_RGB_COLORS)
'    fileName = "c:\white.bmp"
    fnum = FreeFile
    Open fileName For Binary As #fnum
    With bmifh
        .bfType = "BM"
        .bfReserved1 = 0
        .bfReserved2 = 0
        .bfSize = Len(bmifh) + Len(bmi) + UBound(BmpBits) + 1
        .bfOffBits = Len(bmifh) + Len(bmi)
    End With
    Put #fnum, , bmifh
    Put #fnum, , bmi
    Put #fnum, , BmpBits
    Close #fnum
    
    SelectObject hmDC, oldBrush
    SelectObject hmDC, oldPen
    SelectObject hmDC, oldBmp
    DeleteObject hPen
    DeleteObject hBmp
    DeleteObject hmDC
    ReleaseDC 0&, hdc
End Sub