Option Explicit
'http://vbnet.mvps.org/index.html?code/imageapi/createenhmetafileps.htm
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2009 VBnet, Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Const HORZSIZE As Long = 4 'Horizontal size in millimetres
Private Const VERTSIZE As Long = 6 'Vertical size in millimetres
Private Const HORZRES As Long = 8 'Horizontal width in pixels
Private Const VERTRES As Long = 10 'Vertical width in pixels
Private Const STRETCH_ANDSCANS As Long = 1
Private Const STRETCH_ORSCANS As Long = 2
Private Const STRETCH_DELETESCANS As Long = 3
Private Const STRETCH_HALFTONE As Long = 4
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function CreateEnhMetaFile Lib "gdi32" _
Alias "CreateEnhMetaFileA" _
(ByVal hdcRef As Long, _
ByVal lpFileName As String, _
ByRef lpRect As Rect, _
ByVal lpDescription As String) As Long
Private Declare Function CloseEnhMetaFile Lib "gdi32" _
(ByVal hDC As Long) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" _
(ByVal hEMF As Long) As Long
Private Declare Function PlayEnhMetaFile Lib "gdi32" _
(ByVal hDC As Long, _
ByVal hEMF As Long, _
ByRef lpRect As Any) 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 GetDeviceCaps Lib "gdi32" _
(ByVal hDC As Long, _
ByVal nIndex As Long) As Long
Private Declare Function GetClientRect Lib "user32" _
(ByVal hwnd As Long, _
ByRef lpRect As Rect) As Long
Private Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, _
lpRect As Rect) As Long
Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, _
ByVal hDC As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" _
(ByVal hDC As Long, _
ByVal nStretchMode As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Sub Form_Load()
Picture1.AutoRedraw = True
Command1.Caption = "Create Metafile"
End Sub
Private Sub Picture1_Click()
Picture1.Cls 'Reset
End Sub
Private Sub Command1_Click()
Dim hEMF As Long
Dim rc As Rect
'Obtain a handle to a Windows
'enhanced metafile of the desktop
'(or to the client area of another
'form or window specified by hwnd),
'and optionally display the result
'in a picturebox using metafile APIs,
'then clean up
hEMF = WindowClientToEMF(GetDesktopWindow(), "C:\TempEMF.emf")
Call Picture1.Cls
Call GetClientRect(Picture1.hwnd, rc)
Call PlayEnhMetaFile(Picture1.hDC, hEMF, rc)
Call Picture1.Refresh
Call DeleteEnhMetaFile(hEMF)
End Sub
Private Function WindowClientToEMF(ByVal hwndIn As Long, _
sOutputFile As String) As Long
Dim rc As Rect
Dim hTmpDc As Long
'obtain the display context (DC)
'to the window passed
hTmpDc = GetDC(hwndIn)
If hTmpDc <> 0 Then
'get the size of the client
'area of the passed handle
If GetClientRect(hwndIn, rc) <> 0 Then
'pass the DC, rectangle and filename
'to create the file, returning the
'handle to the memory metafile
WindowClientToEMF = DcToEmf2(hTmpDc, rc, sOutputFile)
'release the temporary DC
Call ReleaseDC(hwndIn, hTmpDc)
End If
End If
End Function
Private Function DcToEmf2(ByVal hDcIn As Long, _
inArea As Rect, _
sOutputFile As String) As Long
Dim rc As Rect
Dim MetaDC As Long
Dim OldMode As Long
Dim hsize As Long
Dim vsize As Long
Dim hres As Long
Dim vres As Long
'Convert the area from pixels to .01mm's
'Rectangle coordinates must be normalised
hsize = GetDeviceCaps(hDcIn, HORZSIZE) * 100
vsize = GetDeviceCaps(hDcIn, VERTSIZE) * 100
hres = GetDeviceCaps(hDcIn, HORZRES)
vres = GetDeviceCaps(hDcIn, VERTRES)
With rc
.Left = (inArea.Left * hsize) / hres
.Top = (inArea.Top * vsize) / vres
.Right = (inArea.Right * hsize) / hres
.Bottom = (inArea.Bottom * vsize) / vres
End With
'Create a new MetaDC and output file
MetaDC = CreateEnhMetaFile(hDcIn, sOutputFile, rc, vbNullString)
If (MetaDC) Then
'Draw the image to the MetaDC
'Set STRETCH_HALFTONE stretch mode here for higher quality
OldMode = SetStretchBltMode(MetaDC, STRETCH_HALFTONE)
Call BitBlt(MetaDC, _
0, 0, _
(inArea.Right - inArea.Left), _
(inArea.Bottom - inArea.Top), _
hDcIn, _
inArea.Left, _
inArea.Top, _
vbSrcCopy)
'restore the saved dc mode
Call SetStretchBltMode(MetaDC, OldMode)
'delete the MetaDC and return the
'EMF object's handle
DcToEmf2 = CloseEnhMetaFile(MetaDC)
End If
End Function |
Комментариев нет:
Отправить комментарий