DelphiFAQ Home Search:

Printing a TForm

 

comments29 comments. Current rating: 5 stars (5 votes). Leave comments and/ or rate it.

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!

Comments:

You are on page 1 of 2, other pages: [1] 2
2006-09-04, 04:38:35
anonymous from Israel  
it doesn't work that well.
and too complicate for me to check and make changes.
2006-10-10, 09:51:34
anonymous from United States  
Agree - too complicated - hangs up the compiler so bad, system had to be rebooted!
2008-01-21, 03:59:41
[hidden] from United Kingdom  
rating
worked a treat, little bit small, no problems
2008-11-05, 07:33:37
hals@iinet.net.au from Australia  
rating
Brilliant -> Works Well, Ignore all other comments
2009-01-14, 13:54:25
anonymous from Canada  
rating
Worked very well without any modification whatsoever (Delphi 6). Thanks very much!!
2009-03-23, 01:16:17
anonymous from Malaysia  
rating
Yeah, works fine. Just need to add 'Printers' at the 'uses' part. But how if I just want to preview it? or remove the windows title bar? Plus, when print, it printed whatever was 'on' (i.e. other non-related program) the form as well.
2012-06-21, 20:58:58
anonymous from Malaysia  
1. SUBOH BIN RAHIM
2. NO.13 TMJ 8,TMN TANJONG MINYAK JAYA,75250 MELAKA
3. MOBILE: 013-514-3508
4. HOUSE: +606-334-5364
5. BANK NAME: MALAYAN BANKING BERHAD
6. BANK ACCOUNT: 104068242480
7.ACCOUNT NAME: SUBOH BIN RAHIM

THANK YOU
This image was also posted here:
The UK NATIONAL LOTTERY scam
The UK NATIONAL LOTTERY scam



Keywords:
2014-06-16, 01:41:35
anonymous from Malaysia  
mELAKA my
2014-06-16, 01:42:40
anonymous from Malaysia  
MELAKA MY
2014-06-16, 01:43:41
anonymous from Malaysia  
MELAKA MY
2014-06-16, 01:44:27
anonymous from Malaysia  
MELAKA MY
2014-06-16, 01:45:22
anonymous from Malaysia  
MELAKA MY
2014-06-16, 01:46:12
anonymous from Malaysia  
MELAKA MY
2014-06-16, 01:46:49
anonymous from Malaysia  
MELAKA MY
2014-06-16, 01:47:52
anonymous from Malaysia  
MELAKA MY
You are on page 1 of 2, other pages: [1] 2

 

 

NEW: Optional: Register   Login
Email address (not necessary):

Rate as
Hide my email when showing my comment.
Please notify me once a day about new comments on this topic.
Please provide a valid email address if you select this option, or post under a registered account.
 

Show city and country
Show country only
Hide my location
You can mark text as 'quoted' by putting [quote] .. [/quote] around it.
Please type in the code:

Please do not post inappropriate pictures. Inappropriate pictures include pictures of minors and nudity.
The owner of this web site reserves the right to delete such material.

photo Add a picture: