Валентин Озеров - Советы по Delphi. Версия 1.4.3 от 1.1.2001

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;

ifGetDeviceCaps(dc, RASTERCAPS) andRC_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);

ifpPal^.PalNumEntries <> 0 then begin

pal := CreatePalette(pPal^);

oldPal := SelectPalette(MemDc, Pal, false);

isDcPalDevice := true

end elseFreeMem(pPal, sizeof(TLOGPALETTE) +(255 * sizeof(TPALETTEENTRY)));

end;

{копируем экран в memdc/bitmap}

BitBlt(MemDc,0, 0, form1.width, form1.height, Dc, form1.left, form1.top, SrcCopy);

ifisDcPalDevice = 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);

{Пробуем исправить ошибки некоторых видеодрайверов}

ifisDcPalDevice = true then begin

fori := 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;

{Масштабируем размер печати}

ifPrinter.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;

ifGetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) andRC_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;

fori := 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);

{Просто используем драйвер принтера для устройства палитры}

ifisDcPalDevice = true then begin