How to Print Form/Client Area in 256 Colors w/StretchDIBits
ID: Q118938
|
The information in this article applies to:
-
Microsoft Visual Basic Standard and Professional Editions for Windows, versions 2.0, 3.0
SUMMARY
Versions 2.0 and 3.0 of Visual Basic have the ability to display 256-color
bitmaps in forms, image controls, and picture boxes. These versions can
also print forms containing these controls with the PrintForm method.
However, the PrintForm method has the following limitations:
- You do not have control over the size and position of the output on the
page.
- You cannot print the forms' borders.
- You cannot print multiple forms on a page.
- You cannot print text on the same page.
This article describes how to use the Windows Application Programming
Interface (API) to print a form or its client area and render the 256-color
bitmaps as they are displayed on the screen.
The example code in this article uses the StretchDIBits function from the
Windows API and has the following advantages:
- You have 256 colors to work with.
- You can print on both PostScript and PCL printers.
- You can take advantage of printer halftones.
- You can print a specified portion of a picture.
- You can stretch the output to a specified location and size.
- You can print both text and graphics to the same page.
- You can print multiple forms on a page.
MORE INFORMATION
The example code included with this article uses the Windows API
extensively, showing how the form is printed to the printer. (For
additional information on this process, please see the comments in the code
below or the Windows SDK documentation.) This process is only slightly
different when printing the client area of the form. Most of the work done
is the same in both cases. In the example code, there are two routines
named PrintForm256() and PrintClient256(). Both of these routines call the
routine StretchFormToDC() to do the bulk of the printing. The routines
PrintForm256() and PrintClient256() basically get a handle to the desired
portion of the form, start the print job, and calculate the size of the
output on the printed page. Then they call StretchFormToDC to copy the
bitmap. Afterward, PrintForm256() and PrintClient256() clean up as
necessary for the part of the form that was copied and then they end the
print job.
Once you have tried out the code and you have an idea of how it works, you
can make modifications to the PrintForm256() and PrintClient256() routines.
You could modify these routines to print multiple forms on the same page by
calling StretchFormToDC() multiple times with the appropriate parameters.
You could also print text to the same page by using the Print method of the
printer object before ending the document (Printer.EndDoc) or going to a
new page (Printer.NewPage).
Example
- Start a new project in Visual Basic; Form1 is created by default.
- Put a picture box control on the form; Picture1 is created by default.
- Assign a 256-color bitmap to the Picture property of the picture box.
- Put a common dialog control on the form; CMDialog1 is created by
default.
- Place two command buttons on the form; Command1 and Command2 are created
by default.
- Add the following code to the click event of the first command button:
Sub Command1_Click ()
' Allow user to set up printer.
CMDialog1.Flags = &H40& ' Printer setup.
CMDialog1.Action = 5 ' Show dialog.
' Print the form.
Call PrintForm256(Form1)
End Sub
- Add the following code to the Click() event of the second command
button:
Sub Command2_Click ()
' Allow user to set up printer.
CMDialog1.Flags = &H40& ' Printer setup.
CMDialog1.Action = 5 ' Show dialog.
' Print the client area.
Call PrintClient256(Form1)
End Sub
- Add a new module to the project; MODULE1.BAS is created by default.
- Put the example code listed at the end of these steps in the basic
module.
- Save the project.
- Run the project. Try pressing each of the buttons. The example should be
able to print out the form as large as possible with the chosen
orientation. If your printer driver does not support StretchDIBits, then
you will receive error message 11105.
Example Code
'--------------------------------------------------------------------------
' 256-Color Form Printing Routines
'
' General Declarations: Types, Constants, and Declares
'
' Routines:
' - PrintForm256()
' - PrintClient256()
' - StretchFormToDC
'--------------------------------------------------------------------------
Option Explicit
Type PALETTEENTRY
peRed As String * 1
peGreen As String * 1
peBlue As String * 1
peFlags As String * 1
End Type
Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors
End Type
Type BITMAPINFOHEADER
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
Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(255) As PALETTEENTRY 'Enough for 256 colors
End Type
Type RECT
Left As Integer
Top As Integer
Right As Integer
Bottom As Integer
End Type
Global Const PIXELS = 3
Global Const SRCCOPY = &HCC0020
Global Const BI_RGB = 0
Global Const DIB_RGB_COLORS = 0
Global Const GMEM_MOVEABLE = 2
Global Const RASTERCAPS = 38
Global Const RC_STRETCHDIB = &H2000
Global Const RC_PALETTE = &H100
Global Const PLANES = 14
Global Const BITSPIXEL = 12
Global Const SIZEPALETTE = 104
'The following declares must each be entered on a single line:
Declare Function CreateCompatibleDC Lib "GDI" (ByVal hDC As Integer
) As Integer
Declare Function CreateCompatibleBitmap Lib "GDI" (ByVal hDC As Integer,
ByVal nWidth As Integer, ByVal nHeight As Integer) As Integer
Declare Function GetDeviceCaps Lib "GDI" (ByVal hDC As Integer,
ByVal iCapabilitiy As Integer) As Integer
Declare Function GetSystemPaletteEntries Lib "GDI" (ByVal hDC As Integer,
ByVal wStartIndex As Integer, ByVal wNumEntries As Integer,
lpPaletteEntries As PALETTEENTRY) As Integer
Declare Function CreatePalette Lib "GDI" (lpLogPalette As LOGPALETTE
) As Integer
Declare Function SelectObject Lib "GDI" (ByVal hDC As Integer,
ByVal hObject As Integer) As Integer
Declare Function BitBlt Lib "GDI" (ByVal hDCDest As Integer,
ByVal XDest As Integer, ByVal YDest As Integer, ByVal nWidth As Integer,
ByVal nHeight As Integer, ByVal hDCSrc As Integer, ByVal XSrc As
Integer,
ByVal YSrc As Integer, ByVal dwROP As Long) As Integer
Declare Function GetDIBits Lib "GDI" (ByVal hDC As Integer,
ByVal hBitmap As Integer, ByVal nStartScan As Integer,
ByVal nNumScans As Integer, ByVal lpBits As Long, BITMAPINFO As
BITMAPINFO
,
ByVal wUsage As Integer) As Integer
Declare Function StretchDIBits Lib "GDI" (ByVal hDC As Integer,
ByVal DestX As Integer, ByVal DestY As Integer,
ByVal wDestWidth As Integer, ByVal wDestHeight As Integer,
ByVal SrcX As Integer, ByVal SrcY As Integer, ByVal wSrcWidth As
Integer,
ByVal wSrcHeight As Integer, ByVal lpBits As Long, BitsInfo As
BITMAPINFO,
ByVal wUsage As Integer, ByVal dwROP As Long) As Integer
Declare Function DeleteObject Lib "GDI" (ByVal hObject As Integer) As
Integer
Declare Function DeleteDC Lib "GDI" (ByVal hDC As Integer) As Integer
Declare Function GlobalAlloc Lib "KERNEL" (ByVal wFlags As Integer,
ByVal lMem As Long) As Integer
Declare Function GlobalLock Lib "KERNEL" (ByVal hMem As Integer) As Long
Declare Function GlobalUnlock Lib "KERNEL" (ByVal hMem As Integer) As
Integer
Declare Function GlobalFree Lib "KERNEL" (ByVal hMem As Integer) As Integer
Declare Function SelectPalette Lib "USER" (ByVal hDC As Integer,
ByVal hPalette As Integer, ByVal bForceBackground As Integer) As Integer
Declare Function RealizePalette Lib "USER" (ByVal hDC As Integer) As
Integer
Declare Function GetWindowDC Lib "USER" (ByVal hWnd As Integer) As Integer
Declare Function GetWindowRect Lib "USER" (ByVal hWnd As Integer,
lpRect As RECT) As Integer
Declare Function ReleaseDC Lib "USER" (ByVal hWnd As Integer,
ByVal hDC As Integer) As Integer
' Error Constants:
' Device does not support StretchDIBits.
Global Const ERR_DEVSTRETCHDIB = 11105
' Palette is not 256-color palette.
Global Const ERR_PALSIZE = 11106
' Unable to create device context.
Global Const ERR_CREATEMEMDC = 11107
' Unable to create bitmap.
Global Const ERR_CREATEBMP = 11108
' Unable to retrieve system palette.
Global Const ERR_GETPALETTE = 11109
' Unable to create a new palette.
Global Const ERR_CREATEPAL = 11120
' Unable to copy bitmap to memory.
Global Const ERR_BITBLT = 11110
' Unable to allocate memory for DIB bits.
Global Const ERR_BITMEM = 11111
' Unable to lock DIB bits memory.
Global Const ERR_LOCKBITMEM = 11112
' Unable to get DIB bits.
Global Const ERR_GETDIB = 11113
' Unable to copy bitmap to destination.
Global Const ERR_STRETCHDIB = 11114
' Unable to unlock DIB bits memory.
Global Const ERR_UNLOCKMEM = 11115
' Unable to free DIB bits memory.
Global Const ERR_FREEMEM = 11116
' Unable to select palette.
Global Const ERR_SELPAL = 11117
' Unable to delete palette.
Global Const ERR_DELPAL = 11121
' Unable to delete bitmap.
Global Const ERR_DELBMP = 11118
' Unable to select palette.
Global Const ERR_DELMEMDC = 11119
'--------------------------------------------------------------------------
' PrintForm256:
' - Prints the entire form.
' - Renders 256-color bitmaps as they appear on the form.
' - Adjusts output to the size and orientation of the printer's page.
' - Calls StretchFormToDC to copy the contents of the form to the printer.
' - Starts and ends a print job.
'
' frmSrc:
' - The form object to print.
'
' Errors:
' - A message box is displayed for StrechFormToDC errors.
' - Otherwise, ther is no error trapping.
'
'--------------------------------------------------------------------------
Sub PrintForm256 (frmSrc As Form)
Dim RectWindow As RECT
Dim hDCWindow As Integer
Dim WindowWidth As Integer
Dim WindowHeight As Integer
Dim WindowRatio As Double
Dim PrinterWindowWidth As Integer
Dim PrinterWindowHeight As Integer
Dim PrinterRatio As Double
Dim r
Screen.MousePointer = 11 ' Hourglass
' Setup form.
hDCWindow = GetWindowDC(frmSrc.hWnd) ' hDC of form, including borders
r = GetWindowRect(frmSrc.hWnd, RectWindow)
WindowWidth = Abs(RectWindow.Right - RectWindow.Left)
WindowHeight = Abs(RectWindow.Bottom - RectWindow.Top)
' The following must be entered on a single line:
WindowRatio = (WindowWidth * Screen.TwipsPerPixelX) /
(WindowHeight * Screen.TwipsPerPixelY)
' Setup printer.
Printer.ScaleMode = PIXELS
Printer.Print ""; ' Start print job; initialize printer object.
' The following must be entered on a single line:
PrinterRatio = (Printer.ScaleWidth * Printer.TwipsPerPixelX) /
(Printer.ScaleHeight * Printer.TwipsPerPixelY)
' Scale the output to the page size.
If WindowRatio >= PrinterRatio Then
PrinterWindowWidth = Printer.ScaleWidth
' The following must be entered on a single line:
PrinterWindowHeight = (PrinterWindowWidth * Printer.TwipsPerPixelX) /
(WindowRatio * Printer.TwipsPerPixelY)
Else
PrinterWindowHeight = Printer.ScaleHeight
' The following must be entered on a single line:
PrinterWindowWidth = (PrinterWindowHeight * Printer.TwipsPerPixelY *
WindowRatio) / Printer.TwipsPerPixelX
End If
' Print the form.
On Error Resume Next
' The following must be entered on a single line:
Call StretchFormToDC(CInt(Printer.hDC), 0, 0, PrinterWindowWidth,
PrinterWindowHeight, hDCWindow, 0, 0, WindowWidth, WindowHeight)
If Err Then
MsgBox Err & ": Error Printing Form"
' Predefined error codes are commented in the general declarations.
End If
On Error GoTo 0
' Clean up.
r = ReleaseDC(frmSrc.hWnd, hDCWindow) ' Free DC.
' End print job.
Printer.EndDoc
Screen.MousePointer = 0 ' Default
End Sub
'--------------------------------------------------------------------------
' PrintClient256:
' - Prints the client area of a form passed to it.
' - Renders 256-color bitmaps as they appear on the form.
' - Adjusts output to the size and orientation of the printer's page.
' - Calls StretchFormToDC to copy the contents of the form to the printer.
' - Starts and ends a print job.
'
' frmSrc:
' - The form object to print
'
'Errors
' - Displays a message box for StrechFormToDC errors.
' - Otherwise, there is no error trapping.
'
'--------------------------------------------------------------------------
Sub PrintClient256 (frmSrc As Form)
Dim hDCWindow As Integer
Dim WindowWidth As Integer
Dim WindowHeight As Integer
Dim WindowRatio As Double
Dim PrinterWindowWidth As Integer
Dim PrinterWindowHeight As Integer
Dim PrinterRatio As Double
Dim r
Screen.MousePointer = 11 ' Hourglass
' Setup form.
frmSrc.ScaleMode = PIXELS ' All dimensions must be in pixels.
hDCWindow = frmSrc.hDC ' hDC of client area
WindowWidth = frmSrc.ScaleWidth
WindowHeight = frmSrc.ScaleHeight
' The following must be entered on a single line:
WindowRatio = (WindowWidth * Screen.TwipsPerPixelX) /
(WindowHeight * Screen.TwipsPerPixelY)
' Setup printer.
Printer.ScaleMode = PIXELS
Printer.Print ""; ' Start print job; initialize printer object.
' The following must be entered on a single line:
PrinterRatio = (Printer.ScaleWidth * Printer.TwipsPerPixelX) /
(Printer.ScaleHeight * Printer.TwipsPerPixelY)
' Scale the output to the page size.
If WindowRatio >= PrinterRatio Then
PrinterWindowWidth = Printer.ScaleWidth
' The following must be entered on a single line:
PrinterWindowHeight = (PrinterWindowWidth * Printer.TwipsPerPixelX) /
(WindowRatio * Printer.TwipsPerPixelY)
Else
PrinterWindowHeight = Printer.ScaleHeight
' The following must be entered on a single line:
PrinterWindowWidth = (PrinterWindowHeight * Printer.TwipsPerPixelY *
WindowRatio) / Printer.TwipsPerPixelX
End If
' Print the client area.
On Error Resume Next
' The following must be entered on a single line:
Call StretchFormToDC(CInt(Printer.hDC), 0, 0, PrinterWindowWidth,
PrinterWindowHeight, hDCWindow, 0, 0, WindowWidth, WindowHeight)
If Err Then
MsgBox Err & ": Error Printing Client Area"
' Predefined error codes are commented in the general declarations.
End If
On Error GoTo 0
' End the print job.
Printer.EndDoc
Screen.MousePointer = 0 ' Default
End Sub
'--------------------------------------------------------------------------
' StretchFormToDC
' - Stretches a specified portion of a form to a device context.
' - Works with 256 colors.
' - Works on PostScript and PCL printers (driver must support
' StretchDIBits).
' - Allows you to output to other device contexts
'
' hDCDest:
' - Destination device context.
' - ScaleMode of device context must be pixels.
' - If using Printer object, the printer should be initialized. This can
' be accomplished with Printer.Print ""; or any other printing.
'
' LeftDest, TopDest, WidthDest, HeightDest:
' - Describe the location and size of the image on the printer in pixels.
'
' hDCSrc:
' - The source device context; should be from a form.
'
' LeftSrc, TopSrc, WidthSrc, HeightSrc:
' - Describe the location and size of the source image in pixels.
'
' Errors:
' - Errors with a predefined code if necessary.
'
'--------------------------------------------------------------------------
' The following must be entered on a single line:
Sub StretchFormToDC (hDCDest As Integer, LeftDest, TopDest, WidthDest,
HeightDest, hDCSrc As Integer, LeftSrc, TopSrc, WidthSrc, HeightSrc)
Dim BMI As BITMAPINFO
Dim hMem As Integer
Dim lpBits As Long
Dim r As Integer
Dim hDCMemory As Integer
Dim hBmp As Integer
Dim hBmpPrev As Integer
Dim hPal As Integer
Dim hPalPrev As Integer
Dim RasterCapsDest As Integer
Dim RasterCapsSrc As Integer
Dim HasPaletteSrc As Integer
Dim BitsPixelSrc As Integer
Dim PlanesSrc As Integer
Dim PaletteSizeSrc As Integer
Dim LogPal As LOGPALETTE
' Set error trap.
On Error GoTo SFTDC_ERRORS:
' Check that destination supports StretchDIBits.
RasterCapsDest = GetDeviceCaps(hDCDest, RASTERCAPS)
If (RasterCapsDest And RC_STRETCHDIB) <> RC_STRETCHDIB Then
Error ERR_DEVSTRETCHDIB
End If
' Get properties of source device context.
RasterCapsSrc = GetDeviceCaps(hDCSrc, RASTERCAPS)
HasPaletteSrc = RasterCapsSrc And RC_PALETTE
BitsPixelSrc = GetDeviceCaps(hDCSrc, BITSPIXEL)
PlanesSrc = GetDeviceCaps(hDCSrc, PLANES)
PaletteSizeSrc = GetDeviceCaps(hDCSrc, SIZEPALETTE)
' Limit function use to 256-color palettes.
If HasPaletteSrc And (PaletteSizeSrc <> 256) Then Error ERR_PALSIZE
' Copy source to a bitmap in memory.
hDCMemory = CreateCompatibleDC(hDCSrc)
If hDCMemory = 0 Then Error ERR_CREATEMEMDC
hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
If hBmp = 0 Then Error ERR_CREATEBMP
hBmpPrev = SelectObject(hDCMemory, hBmp)
' Create a copy of the system palette and realize it if necessary.
If HasPaletteSrc Then
LogPal.palVersion = &H300
LogPal.palNumEntries = 256
r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
If r = 0 Then Error ERR_GETPALETTE
hPal = CreatePalette(LogPal)
If hPal = 0 Then Error ERR_CREATEPAL
' Select the palette into the destination and realize it.
hPalPrev = SelectPalette(hDCMemory, hPal, 0)
r = RealizePalette(hDCMemory)
End If
' Copy the bitmap to the memory-device context.
' The following must be entered on a single line:
r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc,
TopSrc,
SRCCOPY)
If r = 0 Then Error ERR_BITBLT
hBmp = SelectObject(hDCMemory, hBmpPrev)
' Fill in necessary parts of bitmap info.
BMI.bmiHeader.biSize = 40
BMI.bmiHeader.biWidth = WidthSrc
BMI.bmiHeader.biHeight = HeightSrc
BMI.bmiHeader.biPlanes = 1
If BitsPixelSrc * PlanesSrc = 24 Then
' 24-bit True color may require too much memory so
' limit to 256-color DIB.
' You can get rid of this exception and the routine
' should copy 24-bit color bitmaps.
BMI.bmiHeader.biBitCount = 8 ' 8 bits = 256 colors
Else
BMI.bmiHeader.biBitCount = BitsPixelSrc * PlanesSrc
End If
BMI.bmiHeader.biCompression = BI_RGB
' Allocate memory for bitmap bits.
' The following must be entered on a single line:
hMem = GlobalAlloc(GMEM_MOVEABLE, (CLng(WidthSrc *
BMI.bmiHeader.biBitCount + 31) \ 32) * 4 * HeightSrc)
If hMem = 0 Then Error ERR_BITMEM
lpBits = GlobalLock(hMem)
' Get the bits and color information from the bitmap.
' The following must be entered on a single line:
r = GetDIBits(hDCMemory, hBmp, 0, HeightSrc, lpBits, BMI,
DIB_RGB_COLORS)
If r = 0 Then Error ERR_GETDIB
' Stretch the device-independent bitmap to the printer.
' The following must be entered on a single line:
r = StretchDIBits(hDCDest, LeftDest, TopDest, WidthDest, HeightDest, 0,
0,
WidthSrc, HeightSrc, lpBits, BMI, DIB_RGB_COLORS, SRCCOPY)
If r = 0 Then Error ERR_STRETCHDIB
' Free up memory used for bitmap bits.
r = GlobalUnlock(hMem)
If r <> 0 Then Error ERR_UNLOCKMEM
r = GlobalFree(hMem)
If r <> 0 Then Error ERR_FREEMEM
' Select the default palette back if necessary.
If HasPaletteSrc Then
r = SelectPalette(hDCMemory, hPalPrev, 0)
If r = 0 Then Error ERR_SELPAL
r = DeleteObject(hPal)
If r = 0 Then Error ERR_DELPAL
End If
' Delete created objects.
r = DeleteObject(hBmp)
If r = 0 Then Error ERR_DELBMP
r = DeleteDC(hDCMemory)
If r = 0 Then Error ERR_DELMEMDC
On Error GoTo 0
Exit Sub
' Clean up predefined errors if necessary.
SFTDC_ERRORS:
Select Case Err
Case ERR_CREATEBMP
r = DeleteDC(hDCMemory)
Error Err
Case ERR_GETPALETTE, ERR_CREATEPAL
hBmp = SelectObject(hDCMemory, hBmpPrev)
r = DeleteObject(hBmp)
r = DeleteDC(hDCMemory)
Error Err
Case ERR_BITBLT
If HasPaletteSrc Then
r = SelectPalette(hDCMemory, hPalPrev, 0)
r = DeleteObject(hPal)
End If
hBmp = SelectObject(hDCMemory, hBmpPrev)
r = DeleteObject(hBmp)
r = DeleteDC(hDCMemory)
Error Err
Case ERR_BITMEM
If HasPaletteSrc Then
r = SelectPalette(hDCMemory, hPalPrev, 0)
r = DeleteObject(hPal)
End If
r = DeleteObject(hBmp)
r = DeleteDC(hDCMemory)
Error Err
Case ERR_GETDIB, ERR_STRETCHDIB
r = GlobalUnlock(hMem)
r = GlobalFree(hMem)
If HasPaletteSrc Then
r = SelectPalette(hDCMemory, hPalPrev, 0)
r = DeleteObject(hPal)
End If
r = DeleteObject(hBmp)
r = DeleteDC(hDCMemory)
Error Err
Case ERR_UNLOCKMEM, ERR_FREEMEM
If HasPaletteSrc Then
r = SelectPalette(hDCMemory, hPalPrev, 0)
r = DeleteObject(hPal)
End If
r = DeleteObject(hBmp)
r = DeleteDC(hDCMemory)
Error Err
Case ERR_SELPAL, ERR_DELPAL
r = DeleteObject(hBmp)
r = DeleteDC(hDCMemory)
Error Err
Case ERR_DELBMP
r = DeleteDC(hDCMemory)
Error Err
Case Else
Error Err
End Select
Error Err
End Sub
REFERENCES
- "Programming Windows 3.1: The Microsoft Guide to Writing Applications
for Windows 3.1," Charles Petzold, Microsoft Press, 1992.
- "Microsoft Windows Software Development Kit: Programmer's Reference."
- Windows SDK Help file shipped with the Professional Editions of the
Microsoft Visual Basic Programming System for Windows, versions 2.0 and
3.0.
- Windows SDK Knowledge Base Articles Q81498 and Q80080.
Additional query words:
2.00 3.00 dump
Keywords :
Version :
Platform :
Issue type :