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

Озеров Валентин

 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;