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

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

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;