'ビットマップ→emfの生成
'http://tokovalue.web.infoseek.co.jp/CreateEnhMetaFile_U.htm
'http://www.devx.com/vb2themax/Tip/19447
'プリンタの寸法諸元の求め方、デバイスコンテキストの求め方
'http://questionbox.jp.msn.com/qa3024375.html
'http://www.accessclub.jp/bbs5/0008/vba2048.html
'APIの宣言等の入手先
'http://homepage2.nifty.com/nonnon/Win32Api/
'GDI+
'http://arkham46.developpez.com/
'http://www.f3.dion.ne.jp/~element/msaccess/AcTipsFrmGdiClass.html
Const HORZSIZE = 4 '物理画面の幅(ミリメートル単位)
Const VERTSIZE = 6 '物理画面の高さ(ミリメートル単位)
Const HORZRES = 8 '画面の幅(ピクセル単位)
Const VERTRES = 10 '画面の高さ(ピクセル単位)
Const STRETCH_ANDSCANS = 1 '既存のカラー値とAND演算
Const STRETCH_DELETESCANS = 3 'コピー先のピクセルをコピー元のピクセルで置き換え
Const STRETCH_HALFTONE = 4 'コピー先のピクセルの平均カラー値を取得
Const STRETCH_ORSCANS = 2 '既存のカラー値とOR演算
Const SRCCOPY = &HCC0020 'そのまま転送
Private Const CCHDEVICENAME = 32
Private Const CCHFORMNAME = 32
'Const SRCCOPY = &HCC0020
Const vbSrcCopy = &HCC0020
'for read BMP
Private Const DT_LEFT As Long = &H0
Private Const DT_BOTTOM As Long = &H8
Private Const DT_SINGLELINE As Long = &H20
Private Const TRANSPARENT As Long = 1
Private Const GUID_IDISPATCH_INTERFACE As String = "{00020400-0000-0000-C000-000000000046}"
Private Const CF_BITMAP As Long = 2
Private Const CF_PALETTE As Long = 9
Private Const PICTYPE_BITMAP As Long = 1
Private Const IMAGE_BITMAP As Long = 0
Private Const LR_COPYRETURNORG As Long = &H4
Private Const LR_LOADFROMFILE As Long = &H10
Private Const LOGPIXELSX As Long = 88
'For Printer HORZRESがダブっていてまずいかもしれない
'Private Const HORZRES = 8 '実際のスクリーンの幅（実印刷領域）
'Private Const VERTRES = 10 '実際のスクリーンの高さ
Private Const PHYSICALWIDTH = 110 '物理的幅(実用紙サイズ）
Private Const PHYSICALHEIGHT = 111 '物理的高さ
Private Const PHYSICALOFFSETX = 112 '印刷可能な左方向のマージン
Private Const PHYSICALOFFSETY = 113 '印刷可能な上方向のマージン
'プリンタ関係のモジュール
Private Const PD_RETURNDC = &H100
Private Const PD_RETURNDEFAULT = &H400
'画像回転関係
Private Const PixelFormatIndexed As Long = &H10000 ' Indexes into a palette
Private Const PixelFormatGDI As Long = &H20000 ' Is a GDI-supported format
Private Const PixelFormatAlpha As Long = &H40000 ' Has an alpha component
Private Const PixelFormatPAlpha As Long = &H80000 ' Pre-multiplied alpha
Private Const PixelFormatExtended As Long = &H100000 ' Extended color 16 bits/channel
Private Const PixelFormatCanonical As Long = &H200000
Private Const PixelFormatUndefined As Long = 0
Private Const PixelFormatDontCare As Long = 0
Const UnitWorld = 0 ' World coordinate (non-physical unit)
Const UnitDisplay = 1 ' Variable -- for PageTransform only
Const UnitPixel = 2 ' Each unit is one device pixel.
Const UnitPoint = 3 ' Each unit is a printer's point, or 1/72 inch.
Const UnitInch = 4 ' Each unit is 1 inch.
Const UnitDocument = 5 ' Each unit is 1/300 inch.
Const UnitMillimeter = 6 ' Each unit is 1 millimeter.
Private Type SIZEL
cx As Long
cy As Long
End Type
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 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 DEVMODE
dmDeviceName As String * CCHDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Long
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency 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 DOCINF
cbSize As Long '構造体のサイズ
lpszDocName As String 'マネージャに表示される文書名
lpszOutput As Long '0 のとき、プリンタ(lpszOutput$ として出力ファイル名)
lpszDataType As String '(Win95のみ)印刷ジョブを記録するデータタイプ
fwType As Long '(Win95のみ)通常、0。バンディングする時、DI_APPBANDING
End Type
'GDI+
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
'プリンタ関係のモジュール
Private Type tagPRINTDLG
lStructSize As Long '構造体のバイト数
hwndOwner As Long 'ダイアログの親ウインドウのハンドル
hDevMode As Long '（戻り値）DEVMODE構造体
hDevNames As Long '（戻り値）DEVNAMES構造体
hdc As Long 'デバイスコンテキストのハンドル
Flags As Long '動作を指定する次の定数
nFromPage As Integer
nToPage As Integer
nMinPage As Integer
nMaxPage As Integer
nCopies As Integer
hInstance As Long
lCustData As Long
lpfnPrintHook As Long
lpfnSetupHook As Long
lpPrintTemplateName As Long 'String
lpSetupTemplateName As Long 'String
hPrintTemplate As Long
hSetupTemplate As Long
End Type
Enum MatrixOrder
MatrixOrderPrepend = 0
MatrixOrderAppend = 1
End Enum
'This Enum is needed to set the "Mapping" property for EMF images
Private Enum MMETRIC
MM_HIMETRIC = 3
MM_LOMETRIC = 2
MM_LOENGLISH = 4
MM_ISOTROPIC = 7
MM_HIENGLISH = 5
MM_ANISOTROPIC = 8
MM_ADLIB = 9
End Enum
' 拡張メタファイルの新規作成
Private Declare Function CreateEnhMetaFile Lib "gdi32" Alias "CreateEnhMetaFileA" (ByVal hdcRef As Long, ByVal lpFileName As String, lpRect As RECT, ByVal lpDescription As String) 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, lpRect As RECT) As Long
Private Declare Function GetEnhMetaFile Lib "gdi32" Alias "GetEnhMetaFileA" (ByVal lpszMetaFile As String) 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 CloseEnhMetaFile Lib "gdi32" (ByVal hdc 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 GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
' ウィンドウのクライアント領域の座標を取得
'Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
'' ウィンドウの座標をスクリーン座標系で取得
'Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
' 指定されたデバイスコンテキストのビットマップ伸縮モードを設定
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) 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 CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetObject Lib "gdi32" _
Alias "GetObjectA" _
(ByVal hObject As Long, _
ByVal nCount As Long, _
ByRef lpObject As Any) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, _
ByVal dwRop As Long) As Long
Private Declare Function SetMapMode Lib "gdi32" (ByVal hdc As Long, _
ByVal nMapMode As Long) As Long
Private Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpszDrive As String, ByVal lpszDevice As String, ByVal lpszOutput As Long, lpInitData As DEVMODE) As Long
'Private Declare Function GetLastError Lib "kernel32" () As Long
'GDI+
Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" (FileName As Any, BITMAP As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
Private Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal image As Long, Height As Long) As Long
Private Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal image As Long, Width As Long) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, pInput As GdiplusStartupInput, pOutput As Any) As Long
Private Declare Function GdipGetImageHorizontalResolution Lib "gdiplus" (ByVal image As Long, resolution As Single) As Long
Private Declare Function GdipGetImageVerticalResolution Lib "gdiplus" (ByVal image As Long, resolution As Single) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal BITMAP As Long, ByRef hbmReturn As Long, _
ByVal Background As Long) As Long
Private Declare Function GdipGetDC Lib "gdiplus" (ByVal graphics As Long, hdc As Long) As Long
Private Declare Function GdipReleaseDC Lib "gdiplus" (ByVal graphics As Long, ByVal hdc As Long) As Long
Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal image As Long, graphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As Long
'GDI+ Rotate
Public Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus.dll" (ByVal nWidth As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, scan0 As Any, nBitmap As Long) As Long
Public Declare Function GdipCreateSolidFill Lib "gdiplus.dll" (ByVal pColor As Long, ByRef brush As Long) As Long
Public Declare Function GdipFillRectangle Lib "gdiplus.dll" (ByVal graphics As Long, ByVal brush As Long, ByVal x As Single, ByVal y As Single, ByVal nWidth As Single, ByVal nHeight As Single) As Long
Public Declare Function GdipDeleteBrush Lib "gdiplus.dll" (ByVal brush As Long) As Long
Public Declare Function GdipTranslateWorldTransform Lib "gdiplus.dll" (ByVal graphics As Long, ByVal dx As Single, ByVal dy As Single, ByVal order As Long) As Long
Public Declare Function GdipRotateWorldTransform Lib "gdiplus" (ByVal graphics As Long, ByVal angle As Single, ByVal order As MatrixOrder) As Long
Public Declare Function GdipDrawImageRectRectI Lib "gdiplus.dll" (ByVal graphics As Long, ByVal nImage As Long, ByVal dstx As Long, ByVal dsty As Long, ByVal dstWidth As Long, ByVal dstHeight As Long, ByVal srcx As Long, ByVal srcy As Long, ByVal srcWidth As Long, ByVal srcHeight As Long, ByVal srcUnit As Long, Optional ByVal imageAttributes As Long, Optional ByVal pCALLBACK As Long, Optional ByVal callbackData As Long) As Long
'for printer
Private Declare Function StartDoc Lib "gdi32" Alias "StartDocA" (ByVal hdc As Long, lpdi As DOCINF) As Long
Private Declare Function StartPage Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function EndPage Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function EndDoc Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function PrintDlg Lib "COMDLG32" Alias "PrintDlgA" (lppd As tagPRINTDLG) As Long
'================================================================
' メインプログラム 画像ファイルを読み込んで、A4一杯に印刷する
' 出力先はActive Printer
'
'================================================================
'
Sub picToEMF()
Dim udtInput As GdiplusStartupInput
Dim lngToken As Long, lngStatus As Long
Dim pSrcBmp As Long, pImageTemp As Long
Dim lngWidth As Long, lngHeight As Long
Dim srcPath As String
Dim tempFilePath As String
Dim rc As RECT
Dim ret As Long
Dim hdc As Long, hBmp As Long, hEmf As Long
srcPath = Application.GetOpenFilename("画像ファイル, *.jpg;*.tif")
If srcPath = "False" Then Exit Sub
tempFilePath = "C:\temp.emf"
udtInput.GdiplusVersion = 1
If GdiplusStartup(lngToken, udtInput, ByVal 0&) <> 0 Then Exit Sub
If GdipCreateBitmapFromFile(ByVal StrPtr(srcPath), pSrcBmp) <> 0 Then
GdiplusShutdown lngToken
Exit Sub
End If
GdipGetImageWidth pSrcBmp, lngWidth
GdipGetImageHeight pSrcBmp, lngHeight
If lngWidth > lngHeight Then
Call RotateImage(pSrcBmp, pImageTemp, 90, &HFFFFFFFF)
pSrcBmp = pImageTemp
End If
GdipGetImageWidth pSrcBmp, lngWidth
GdipGetImageHeight pSrcBmp, lngHeight
ret = GdipCreateHBITMAPFromBitmap(pSrcBmp, hBmp, 0)
'元画像ファイルからデバイスコンテキストを直接作成
hdc = CreateCompatibleDC(0)
ret = SelectObject(hdc, hBmp)
rc.Left = 0
rc.Top = 0
rc.Bottom = lngHeight
rc.Right = lngWidth
Debug.Print "lngWidth,lngHeight", lngWidth, lngHeight
'emfに変換
hEmf = DcToEmf(hdc, rc, tempFilePath)
emfPrint hEmf
'後始末
DeleteEnhMetaFile hEmf
Kill tempFilePath
ret = ReleaseDC(0, hdc)
GdipDisposeImage pSrcBmp
GdipDisposeImage pImageTemp
GdiplusShutdown lngToken
End Sub
'================================================================
' デバイスコンテキストからメタファイル作成
'
Function DcToEmf(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
Dim ret As Long
'画面の物理サイズ 0.01mm単位に変換
hsize = GetDeviceCaps(hDcIn, HORZSIZE) * 100
vsize = GetDeviceCaps(hDcIn, VERTSIZE) * 100
'画面のpixelサイズ
hres = GetDeviceCaps(hDcIn, HORZRES)
vres = GetDeviceCaps(hDcIn, VERTRES)
rc.Left = (inarea.Left * hsize) / hres
rc.Top = (inarea.Top * vsize) / vres
rc.Right = (inarea.Right * hsize) / hres
rc.Bottom = (inarea.Bottom * vsize) / vres
'メタファイルのデバイスコンテキスト
If Dir(sOutputFile) <> "" Then Kill sOutputFile
MetaDC = CreateEnhMetaFile(hDcIn, sOutputFile, rc, ByVal 0)
If MetaDC Then
'メタファイルのデバイスコンテキストに伸縮モード設定
OldMode = SetStretchBltMode(MetaDC, STRETCH_HALFTONE)
'メタファイルデバイスコンテキストにデスクトップデバイスコンテキストを伸縮コピー
ret = BitBlt(MetaDC, 0, 0, (inarea.Right - inarea.Left), (inarea.Bottom - inarea.Top), hDcIn, inarea.Left, inarea.Top, SRCCOPY)
ret = SetStretchBltMode(MetaDC, OldMode)
DcToEmf = CloseEnhMetaFile(MetaDC)
DeleteDC MetaDC
End If
End Function
'================================================================
' emfファイルを印刷する
'
Private Sub emfPrint(hEmf As Long)
Dim r As RECT
Dim mh As ENHMETAHEADER
Dim emfWidth As Long, emfHeight As Long
'For Printer
Dim ret As Long
Dim hdcPrinter As Long
Dim ActivePrinterName As String
' Dim devm As DEVMODE
Dim intPos As Integer
Dim LeftMargin As Long, TopMargin As Long
Dim RightMargin As Long, BottomMargin As Long
Dim PhysHeight As Long, PhysWidth As Long
Dim lpdi As DOCINF
Dim hvRatio As Double
'ヘッダの取得
GetEnhMetaFileHeader hEmf, Len(mh), mh
With mh
'単位はpixcel
emfWidth = .rclBounds.Right - .rclBounds.Left
emfHeight = .rclBounds.Bottom - .rclBounds.Top
End With
hvRatio = emfHeight / emfWidth '縦横比
' 'プリンターのデバイスコンテキストを取得
hdcPrinter = GetPrinterDC
'マージン、用紙サイズの取得 元のコードはmm単位で求めていたが、ここでは論理単位でやる
PhysWidth = GetDeviceCaps(hdcPrinter, PHYSICALWIDTH)
PhysHeight = GetDeviceCaps(hdcPrinter, PHYSICALHEIGHT)
LeftMargin = GetDeviceCaps(hdcPrinter, PHYSICALOFFSETX)
TopMargin = GetDeviceCaps(hdcPrinter, PHYSICALOFFSETY)
' '描画領域の設定
With r
.Left = LeftMargin
.Top = TopMargin
.Right = PhysWidth - LeftMargin
.Bottom = CLng((PhysWidth - LeftMargin) * hvRatio) 'PhysHeight - TopMargin
End With
'DOCINF 構造体を設定する
With lpdi
.cbSize = Len(lpdi)
.lpszDocName = "TestPrint"
.lpszOutput = 0
.lpszDataType = vbNullString
.fwType = 0
End With
'http://www.accessclub.jp/bbs5/0008/vba2048.html
'印刷ジョブを初期化する
ret = StartDoc(hdcPrinter, lpdi)
'プリンタドライバがデータを受け取れるようにする
ret = StartPage(hdcPrinter)
'prit emf
ret = PlayEnhMetaFile(hdcPrinter, hEmf, r)
' 印刷ジョブを終了
ret = EndDoc(hdcPrinter)
'ハンドルを開放
ret = DeleteDC(hdcPrinter)
End Sub
'================================================================
' Active Printer のDC取得
'
Private Function GetPrinterDC() As Long
Dim rc As Long
Dim lppd As tagPRINTDLG
With lppd
.lStructSize = Len(lppd)
.Flags = PD_RETURNDEFAULT Or PD_RETURNDC
End With
rc = PrintDlg(lppd)
GetPrinterDC = lppd.hdc
End Function
'================================================================
' 画像の回転
'
Private Sub RotateImage(ByRef pSrcBmp As Long, ByRef pDestBmp As Long, ByVal angle As Single, Optional lBackColor As Long = -1)
' Dim retval As Long
Dim lHeight As Long, lWidth As Long
Dim newHeight As Long, newWidth As Long
Dim hBrush As Long
Dim imgGraphics As Long
'GdipCreateBitmapFromScan0の引数に使用
Dim PixelFormat32bppARGB As Long
Const pi As Single = 3.14159265
GdipGetImageHeight pSrcBmp, lHeight
GdipGetImageWidth pSrcBmp, lWidth
'新しい画像に最低限必要なサイズ算出
newWidth = lWidth * Abs(Cos(angle * pi / 180)) + lHeight * Abs(Sin(angle * pi / 180))
newHeight = lWidth * Abs(Sin(angle * pi / 180)) + lHeight * Abs(Cos(angle * pi / 180))
'; オフスクリーンバッファ Image、Graphics 作成
PixelFormat32bppARGB = 10 Or BitShift(32, 8) Or PixelFormatAlpha Or PixelFormatGDI Or PixelFormatCanonical
GdipCreateBitmapFromScan0 newWidth, newHeight, 0, PixelFormat32bppARGB, ByVal 0&, pDestBmp
GdipGetImageGraphicsContext pDestBmp, imgGraphics
GdipCreateSolidFill lBackColor, hBrush
GdipFillRectangle imgGraphics, hBrush, 0, 0, newWidth, newHeight
GdipDeleteBrush hBrush
'回転
GdipTranslateWorldTransform imgGraphics, -lWidth / 2, -lHeight / 2, MatrixOrderAppend
GdipRotateWorldTransform imgGraphics, angle, MatrixOrderAppend
GdipTranslateWorldTransform imgGraphics, newWidth / 2, newHeight / 2, MatrixOrderAppend
GdipDrawImageRectRectI imgGraphics, pSrcBmp, 0, 0, lWidth, lHeight, 0, 0, lWidth, lHeight, UnitPixel, 0, 0, 0
GdipDeleteGraphics imgGraphics
GdipDisposeImage pSrcBmp
End Sub
'================================================================
' ビットシフト関数
'
Private Function BitShift(Value As Long, Shift As Long) As Long
BitShift = Value * 2 ^ Shift
End Function