'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