Советы по Delphi. Версия 1.4.3 от 1.1.2001

 FreeMem(FDevice, 128);

 FreeMem(FDriver, 128);

 FreeMem(FPort, 128);

end;

С уважением, Оргиш Александр

Лучший способ печати формы

Данный документ содержит подробное описание способа печати содержимого формы: получение отдельных битов устройства при 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);