Оформил: DeeCo
Автор: http://www.swissdelphicenter.ch

{ 
 Dieser Code druckt den Inhalt einer Form aus. 
 Jedoch ohne Rand und Titelleiste. 

 This code prints out form1. Without border and caption bar. 
 Print uses the GetFormImage method to obtain a bitmap of the form and 
 draws that to the printer’s HDC. 
}


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Form1.Print;
 end;

 { 
  The following TI details a better way to print the contents of 
  a form, by getting the device independent bits in 256 colors 
  from the form, and using those bits to print the form to the 
  printer. 

  In addition, a check is made to see if the screen or printer 
  is a palette device, and if so, palette handling for the device 
  is enabled. If the screen device is a palette device, an additional 
  step is taken to fill the bitmap's palette from the system palette, 
  overcoming some buggy video drivers who don't fill the palette in. 

  Note: Since this code does a screen shot of the form, the form must 
  be the topmost window and the whole from must be viewable when the 
  form shot is made. 

  Copyright by SWAG SUPPORT TEAM 
  http://gdsoft.com/swag/swag.html 
}


 procedure PrintForm(AForm: TForm; BorderWidth: Integer);
 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,
     AForm.Width,
     AForm.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,
     AForm.Width, AForm.Height,
     Dc,
     AForm.Left, AForm.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       := AForm.Width;
   PBITMAPINFOHEADER(pDibHeader)^.biHeight      := AForm.Height;
   PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;

   {find out how much memory for the bits}
   GetDIBits(dc,
     MemBitmap,
     0,
     AForm.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,
     AForm.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}
   if Printer.PageWidth < Printer.PageHeight then
   begin
     ScaleX := Printer.PageWidth;
     ScaleY := AForm.Height * (Printer.PageWidth / AForm.Width);
   end
   else
   begin
     ScaleX := AForm.Width * (Printer.PageHeight / AForm.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,
     BorderWidth, BorderWidth,
     Round(scaleX)-BorderWidth, Round(scaleY)-BorderWidth,
     0, 0,
     AForm.Width, AForm.Height,
     pBits,
     PBitmapInfo(pDibHeader)^,
     DIB_RGB_COLORS,
     SRCCOPY);

   RotateBitmap(var hDIB: HGlobal; 180; clWhite);

   {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;