Подробное описание способа печати содержимого формы

Данный документ содержит подробное описание способа печати содержимого формы: получение отдельных битов устройства при 256-цветной форме, и использования полученных битов для печати формы на принтере.
Кроме того, в данном коде осуществляется проверка палитры устройства (экран или принтер), и включается обработка палитры соответствующего устройства. Если устройством палитры является устройство экрана, принимаются дополнительные меры по заполнению палитры растрового изображения из системной палитры, избавляющие от некорректного заполнения палитры некоторыми видеодрайверами.
Примечание: Поскольку данный код делает снимок формы, форма должна располагаться на самом верху, поверх остальных форм, быть полность на экране, и быть видимой на момент ее "съемки".
unit Prntit;
interface
uses
 SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
 Controls, Forms, Dialogs, StdCtrls, ExtCtrls;
type
 TForm1 = class(TForm)
 Button1: TButton;
 Image1: TImage;
 procedure Button1Click(Sender: TObject);
 private
 { Private declarations }
 public
 { Public declarations }
 end;
var
 Form1: TForm1;
implementation
{$R *.DFM}
uses Printers;
procedure TForm1.Button1Click(Sender: TObject);
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
 { Получаем dc экрана }
 dc := GetDc(0);
 { Создаем совместимый dc }
 MemDc := CreateCompatibleDc(dc);
 { создаем изображение }
 MemBitmap := CreateCompatibleBitmap(Dc, Form1.Width, Form1.Height);
 { выбираем изображение в dc }
 OldMemBitmap := SelectObject(MemDc, MemBitmap);
 { Производим действия, устраняющие ошибки при работе с некоторыми типами видеодрайверов }
 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;
 { копируем экран в memdc/bitmap }
 BitBlt(MemDc, 0, 0, Form1.Width, Form1.Height, Dc, Form1.Left, Form1.Top, SrcCopy);
 if isDcPalDevice = true then
 begin
 SelectPalette(MemDc, OldPal, false);
 DeleteObject(Pal);
 end;
 { удаляем выбор изображения }
 SelectObject(MemDc, OldMemBitmap);
 { удаляем dc памяти }
 DeleteDc(MemDc);
 { Распределяем память для структуры DIB }
 hDibHeader := GlobalAlloc(GHND, sizeof(TBITMAPINFO) + (sizeof(TRGBQUAD) * 256));
 { получаем указатель на распределенную память }
 pDibHeader := GlobalLock(hDibHeader);
 { заполняем dib-структуру информацией, которая нам необходима в 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 := form1.width;
 PBITMAPINFOHEADER(pDibHeader)^.biHeight := form1.height;
 PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;
 { узнаем сколько памяти необходимо для битов }
 GetDIBits(dc, MemBitmap, 0, Form1.Height, nil, TBitmapInfo(pDibHeader^), DIB_RGB_COLORS);
 { Распределяем память для битов }
 hBits := GlobalAlloc(GHND, PBitmapInfoHeader(pDibHeader)^.BiSizeImage);
 { Получаем указатель на биты }
 pBits := GlobalLock(hBits);
 { Вызываем функцию снова, но на этот раз нам передают биты! }
 GetDIBits(dc, MemBitmap, 0, Form1.Height, pBits, PBitmapInfo(pDibHeader)^, DIB_RGB_COLORS);
 { Пробуем исправить ошибки некоторых видеодрайверов }
 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;
 { Освобождаем dc экрана }
 ReleaseDc(0, dc);
 { Удаляем изображение }
 DeleteObject(MemBitmap);
 { Запускаем работу печати }
 Printer.BeginDoc;
 { Масштабируем размер печати }
 if Printer.PageWidth < Printer.PageHeight then
 begin
 ScaleX := Printer.PageWidth;
 ScaleY := Form1.Height * (Printer.PageWidth / Form1.Width);
 end
 else
 begin
 ScaleX := Form1.Width * (Printer.PageHeight / Form1.Height);
 ScaleY := Printer.PageHeight;
 end;
 { Просто используем драйвер принтера для устройства палитры }
 isDcPalDevice := false;
 if GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and
 RC_PALETTE = RC_PALETTE then
 begin
 { Создаем палитру для 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;
 { посылаем биты на принтер }
 StretchDiBits(Printer.Canvas.Handle,
 0, 0,
 Round(scaleX), Round(scaleY),
 0, 0,
 Form1.Width, Form1.Height,
 pBits,
 PBitmapInfo(pDibHeader)^,
 DIB_RGB_COLORS,
 SRCCOPY);
 { Просто используем драйвер принтера для устройства палитры }
 if isDcPalDevice = true then
 begin
 SelectPalette(Printer.Canvas.Handle, oldPal, false);
 DeleteObject(Pal);
 end;
 { Очищаем распределенную память }
 GlobalUnlock(hBits);
 GlobalFree(hBits);
 GlobalUnlock(hDibHeader);
 GlobalFree(hDibHeader);
 { Заканчиваем работу печати }
 Printer.EndDoc;
end;
Source: Взято с http://delphiworld.narod.ru
ID: 03253
Category:Принтер
Category:WinAPI
Category:Bitmap