Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

Видеокурс программиста и крэкера 5D 2O17
(актуальность: октябрь 2O17)
Свежие инструменты, новые видеоуроки!

  • 400+ видеоуроков
  • 800 инструментов
  • 100+ свежих книг и статей

УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



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

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




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS