Printing a TForm

Problem/Question/Abstract:

Printing a TForm

Answer:

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;