How to Print Form/Client Area in 256 Colors w/StretchDIBits

• Standard and Professional Editions of Microsoft Visual Basic for Windows, versions 2.0 and 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.

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

1. Start a new project in Visual Basic; Form1 is created by default.

2. Put a picture box control on the form; Picture1 is created by default.

3. Assign a 256-color bitmap to the Picture property of the picture box.

4. Put a common dialog control on the form; CMDialog1 is created by default.

5. Place two command buttons on the form; Command1 and Command2 are created by default.

6. 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
   
   

7. 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
   
   

8. Add a new module to the project; MODULE1.BAS is created by default.

9. Put the example code listed at the end of these steps in the basic module.

11.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
'--------------------------------------------------------------------------

Type PALETTEENTRY

    peRed As String * 1
    peGreen As String * 1
    peBlue As String * 1
    peFlags As String * 1

Type LOGPALETTE

    palVersion As Integer
    palNumEntries As Integer
    palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors

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

Type BITMAPINFO

   bmiHeader As BITMAPINFOHEADER
   bmiColors(255) As PALETTEENTRY 'Enough for 256 colors

Type RECT

    Left As Integer
    Top As Integer
    Right As Integer
    Bottom As Integer

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

   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

   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

   ByVal wSrcHeight As Integer, ByVal lpBits As Long, BitsInfo As

   ByVal wUsage As Integer, ByVal dwROP As Long) As Integer
Declare Function DeleteObject Lib "GDI" (ByVal hObject As Integer) As

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

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

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.

' Palette is not 256-color palette.

' Unable to create device context.

' Unable to create bitmap.

' Unable to retrieve system palette.

' Unable to create a new palette.

' Unable to copy bitmap to memory.

' Unable to allocate memory for DIB bits.

' Unable to lock DIB bits memory.

' Unable to get DIB bits.

' Unable to copy bitmap to destination.

' Unable to unlock DIB bits memory.

' Unable to free DIB bits memory.

' Unable to select palette.

' Unable to delete palette.

' Unable to delete bitmap.

' Unable to select palette.

'--------------------------------------------------------------------------
' 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,

      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,

   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,

      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

' Clean up predefined errors if necessary.

   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.