Карта сайта Kansoftware
НОВОСТИУСЛУГИРЕШЕНИЯКОНТАКТЫ
KANSoftWare

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

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;

Текст:

Код предназначен для печати формы на принтере с помощью функции StretchDiBits, которая растягивает и печатает форму на принтере. Код также включает в себя обработку ошибок для некоторых видеодрайверов, которые могут не работать корректно с определенным типом палеток.

Основные точки кода:

  1. Обработка палеток: Код проверяет, является ли контекст устройства (DC) палеткой устройства, то есть это экран или принтер с глубиной цвета 8 бит на пиксель. Если это так, код создает палету и выбирает ее для DC.
  2. Создание битовки: Код создает битовку из формы с помощью функции CreateCompatibleBitmap.
  3. Обработка DIB (Device-Independent Bitmap): Код использует DIB для хранения изображения формы в устройствонезависимом формате, который может быть использован любым устройством, поддерживающим битмапы.
  4. StretchDiBits: Код использует функцию StretchDiBits для растягивания и печати формы на принтере.

Вот некоторые улучшения, которые можно было бы сделать:

  1. Организация кода: Код quite long and complex. Он будет легче читаться, если он будет разбит на более маленькие функции, каждая из которых имеет свою ответственность.
  2. Обработка ошибок: Код имеет некоторые обработки ошибок для конкретных видеодрайверов, но это не полноценная обработка ошибок. Лучше было бы иметь более robust механизм обработки ошибок.
  3. Комментарии кода: В коде нет комментариев, что делает его трудным для понимания, что каждый раздел кода делает.
  4. Имя переменных: Некоторые имена переменных, такие как pPal и pDibHeader, не очень описательны.

Вот упрощенная версия кода:

procedure TForm1.Button1Click(Sender: TObject);
var
  dc: HDC;
  isDcPalDevice: BOOL;
  MemBitmap: HBITMAP;
  pBits: Pointer;
begin
   // Получение контекста устройства и создание совместимой битмапы
  dc := GetDC(0);
  MemBitmap := CreateCompatibleBitmap(dc, Form1.Width, Form1.Height);

   // Копирование формы в битмапу
  BitBlt(dc, 0, 0, Form1.Width, Form1.Height, dc, Form1.Left, Form1.Top, SRCCOPY);

   // Получение информации о DIB (Device-Independent Bitmap)
  pBits := nil;
  GetDIBits(dc, MemBitmap, 0, Form1.Height, nil, nil, DIB_RGB_COLORS);
  pBits := GlobalLock(GetDIBits dc, MemBitmap, 0, Form1.Height, nil, DIB_RGB_COLORS);

   // Растягивание и печать формы на принтере
  Printer.BeginDoc;
  StretchDiBits(Printer.Canvas.Handle, 0, 0, Round(ScaleX), Round(ScaleY), 0, 0, Form1.Width, Form1.Height, pBits, nil, DIB_RGB_COLORS, SRCCOPY);
  Printer.EndDoc;

   // Очистка
  GlobalUnlock(GetDIBits dc, MemBitmap, 0, Form1.Height, nil, DIB_RGB_COLORS);
  GlobalFree(GetDIBits dc, MemBitmap, 0, Form1.Height, nil, DIB_RGB_COLORS);
end;

Обратите внимание, что это упрощенная версия кода и может не работать в вашей конкретной ситуации.

Лучший способ печати формы: получение отдельных битов устройства при 256-цветной форме, и использования полученных битов для печати формы на принтере.

Комментарии и вопросы

Получайте свежие новости и обновления по Object Pascal, Delphi и Lazarus прямо в свой смартфон. Подпишитесь на наш Telegram-канал delphi_kansoftware и будьте в курсе последних тенденций в разработке под Linux, Windows, Android и iOS




Материалы статей собраны из открытых источников, владелец сайта не претендует на авторство. Там где авторство установить не удалось, материал подаётся без имени автора. В случае если Вы считаете, что Ваши права нарушены, пожалуйста, свяжитесь с владельцем сайта.


:: Главная :: Принтеры и Печать ::

реклама
©KANSoftWare (разработка программного обеспечения, создание программ, создание интерактивных сайтов), 2007
Top.Mail.Ru

Время компиляции файла: 2024-12-22 20:14:06
2025-06-16 14:57:22/0.008662223815918/0