DelphiFAQ Home Search:
General :: Programming :: Delphi :: Printing
Find a solution for issues with printing from Delphi applications.

Articles:

This list is sorted by recent document popularity (not total page views).
New documents will first appear at the bottom.

Featured Article

Printing a TForm

If you try to print a Delphi form with the Print() method, it will print but the page is blank.
Instead use the following method.

procedure TForm1.PrintForm;
 var
   DC: HDC;
   isDcPalDevice: Bool;
   MemDC: HDC;
   MemBitmap: HBITMAP;
   OldMemBitmap: HBITMAP;
   hDibHeader: THandle;
   pDibHeader: Pointer;
   hBits: THandle;
   pBits: Pointer;
   ScaleX: Double;
   ScaleY: Double;
   pPal: PLOGPALETTE;
   pal: HPALETTE;
   OldPal: HPALETTE;
   i: Integer;
 begin
   {Get the screen dc}
   DC := GetDC(0);
   {Create a compatible dc}
   MemDC := CreateCompatibleDC(DC);
   {create a bitmap}
   MemBitmap := CreateCompatibleBitmap(DC, Self.Width, Self.Height);
   {select the bitmap into the dc}
   OldMemBitmap := SelectObject(MemDC, MemBitmap);
 
   {Lets prepare to try a fixup for broken video drivers}
   isDcPalDevice := False;
   if GetDeviceCaps(DC, RASTERCAPS) and RC_PALETTE=RC_PALETTE then
   begin
     GetMem(pPal, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)));
     FillChar(pPal^, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)),
              #0);
     pPal^.palVersion := $300;
     pPal^.palNumEntries := GetSystemPaletteEntries(DC, 0, 256, pPal^.palPalEntry);
     if pPal^.palNumEntries<>0 then
     begin
       pal := CreatePalette(pPal^);
       OldPal := SelectPalette(MemDC, pal, False);
       isDcPalDevice := True
     end
     else
       FreeMem(pPal, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)));
   end;
   {copy from the screen to the memdc/bitmap}
   BitBlt(MemDC, 0, 0, Self.Width, Self.Height, DC, Self.Left, Self.Top, SRCCOPY);
 
   if isDcPalDevice=True then
   begin
     SelectPalette(MemDC, OldPal, False);
     DeleteObject(pal);
   end;
   {unselect the bitmap}
   SelectObject(MemDC, OldMemBitmap);
   {delete the memory dc}
   DeleteDC(MemDC);
   {Allocate memory for a DIB structure}
   hDibHeader := GlobalAlloc(GHND, SizeOf(TBITMAPINFO)+(SizeOf(TRGBQUAD)*
                             256));
   {get a pointer to the alloced memory}
   pDibHeader := GlobalLock(hDibHeader);
 
   {fill in the dib structure with info on the way we want the DIB}
   FillChar(pDibHeader^, SizeOf(TBITMAPINFO)+(SizeOf(TRGBQUAD)*
            256), #0);
   PBITMAPINFOHEADER(pDibHeader)^.biSize := SizeOf(TBITMAPINFOHEADER);
   PBITMAPINFOHEADER(pDibHeader)^.biPlanes := 1;
   PBITMAPINFOHEADER(pDibHeader)^.biBitCount := 8;
   PBITMAPINFOHEADER(pDibHeader)^.biWidth := Self.Width;
   PBITMAPINFOHEADER(pDibHeader)^.biHeight := Self.Height;
   PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;
 
   {find out how much memory for the bits}
   GetDIBits(DC, MemBitmap, 0, Self.Height, nil, TBITMAPINFO(pDibHeader^),
             DIB_RGB_COLORS);
 
   {Alloc memory for the bits}
   hBits := GlobalAlloc(GHND, PBITMAPINFOHEADER(pDibHeader)^.BiSizeImage);
 
   {Get a pointer to the bits}
   pBits := GlobalLock(hBits);
 
   {Call fn again, but this time give us the bits!}
   GetDIBits(DC, MemBitmap, 0, Self.Height, pBits, PBitmapInfo(pDibHeader)^,
             DIB_RGB_COLORS);
 
   {Lets try a fixup for broken video drivers}
   if isDcPalDevice=True then
   begin
     for i := 0 to (pPal^.palNumEntries-1) do
     begin
       PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed := pPal^.palPalEntry[i].peRed;
       PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen := pPal^.palPalEntry[i].peGreen;
       PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue := pPal^.palPalEntry[i].peBlue;
     end;
     FreeMem(pPal, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)));
   end;
   {Release the screen dc}
   ReleaseDC(0, DC);
   {Delete the bitmap}
   DeleteObject(MemBitmap);
 
   {Start print job}
   Printer.BeginDoc;
 
   {Scale print size }
   ScaleX := Self.Width*3;
   ScaleY := Self.Height*3;
 
   {
   if Printer.PageWidth < Printer.PageHeight then
   begin
     ScaleX := Printer.PageWidth;
     ScaleY := Self.Height*(Printer.PageWidth/Self.Width);
   end
   else
   begin
     ScaleX := Self.Width*(Printer.PageHeight/Self.Height);
     ScaleY := Printer.PageHeight;
   end;
   }
 
   {Just incase the printer drver is a palette device}
   isDcPalDevice := False;
   if GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and RC_PALETTE=RC_PALETTE
                    then
   begin
     {Create palette from dib}
     GetMem(pPal, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)));
     FillChar(pPal^, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)),
              #0);
     pPal^.palVersion := $300;
     pPal^.palNumEntries := 256;
     for i := 0 to (pPal^.palNumEntries-1) do
     begin
       pPal^.palPalEntry[i].peRed := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed;
       pPal^.palPalEntry[i].peGreen := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen;
       pPal^.palPalEntry[i].peBlue := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue;
     end;
     pal := CreatePalette(pPal^);
     FreeMem(pPal, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)));
     OldPal := SelectPalette(Printer.Canvas.Handle, pal, False);
     isDcPalDevice := True
   end;
   {send the bits to the printer}
   StretchDiBits(Printer.Canvas.Handle, 0, 0, Round(ScaleX), Round(ScaleY),
                 0, 0, Self.Width, Self.Height, pBits, PBitmapInfo(pDibHeader)^,
                 DIB_RGB_COLORS, SRCCOPY);
 
   {Just incase you printer drver is a palette device}
   if isDcPalDevice=True then
   begin
     SelectPalette(Printer.Canvas.Handle, OldPal, False);
     DeleteObject(pal);
   end;
   {Clean up allocated memory}
   GlobalUnlock(hBits);
   GlobalFree(hBits);
   GlobalUnlock(hDibHeader);
   GlobalFree(hDibHeader);
 
   {end the print job}
   Printer.EndDoc;
 end;
You don't like the formatting? Check out SourceCoder then!
Generated 16:01:37 on Jul 20, 2017