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

Previous  Top  Next

    
 

 

Данный документ содержит подробное описание способа печати содержимого формы: получение отдельных битов устройства при 256-цветной форме, и использования полученных битов для печати формы на принтере.

 

Кроме того, в данном коде осуществляется проверка палитры устройства (экран или принтер), и включается обработка палитры соответствующего устройства. Если устройством палитры является устройство экрана, принимаются дополнительные меры по заполнению палитры растрового изображения из системной палитры, избавляющие от некорректного заполнения палитры некоторыми видеодрайверами.

 

Примечание: Поскольку данный код делает снимок формы, форма должна располагаться на самом верху, поверх остальных форм, быть полность на экране, и быть видимой на момент ее "съемки".

 

Code:

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;

 

 

©Drkb::03253

       

Взято с http://delphiworld.narod.ru