Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Пример быстрой работы с графикой в среде Windows без использования средств DirectX

Автор: Koster
Прислал: Andrey

Пример быстрой работы с графикой в среде Windows без использования средств DirectX
Совместимость: Windows 95, 98, NT, 2000, Me, TrE, XP, Whistler, Tristler :))

type
  TfmMain = class(TForm)
    pbDraw: TPaintBox;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    procedure CreateBitmap(aSX, aSY: Integer);
    procedure RecreateBitmap(aSX, aSY: Integer);
    procedure DeleteBitmap;
    procedure RestrictSize(var msg: TMessage); message WM_GETMINMAXINFO;
    procedure pbDrawPaint(Sender: TObject);
  private
    ScrBitmap: TBitmap;
    Scr: Pointer;
    SX, SY: Integer;

  type

    TBig = array[0..0] of Integer;

procedure TfmMain.CreateBitmap(aSX, aSY: Integer);
var
  BInfo: tagBITMAPINFO;
begin
  // Создание DIB
  SX := aSX;
  SY := aSY;
  BInfo.bmiHeader.biSize := sizeof(tagBITMAPINFOHEADER);
  BInfo.bmiHeader.biWidth := SX;
  BInfo.bmiHeader.biHeight := -SY;
  BInfo.bmiHeader.biPlanes := 1;
  BInfo.bmiHeader.biBitCount := 32;
  BInfo.bmiHeader.biCompression := BI_RGB;
  ScrBitmap := TBitmap.Create();
  ScrBitmap.Handle := CreateDIBSection(Canvas.Handle, BInfo, DIB_RGB_COLORS,
    Scr, 0, 0);
  ZeroMemory(Scr, SX * SY * 4);
end;

procedure TfmMain.DeleteBitmap;
begin
  // Удаление DIB
  ScrBitmap.FreeImage();
  ScrBitmap.Destroy;
end;

procedure TfmMain.RecreateBitmap(aSX, aSY: Integer);
var
  BInfo: tagBITMAPINFO;
begin
  // Пересоздание DIB при изменении размеров "экрана"
  ScrBitmap.FreeImage();
  SX := aSX;
  SY := aSY;
  BInfo.bmiHeader.biSize := sizeof(tagBITMAPINFOHEADER);
  BInfo.bmiHeader.biWidth := SX;
  BInfo.bmiHeader.biHeight := -SY;
  BInfo.bmiHeader.biPlanes := 1;
  BInfo.bmiHeader.biBitCount := 32;
  BInfo.bmiHeader.biCompression := BI_RGB;
  ScrBitmap.Handle := CreateDIBSection(Canvas.Handle, BInfo, DIB_RGB_COLORS,
    Scr, 0, 0);
  ZeroMemory(Scr, SX * SY * 4);
end;

procedure TfmMain.FormCreate(Sender: TObject);
begin
  CreateBitmap(pbDraw.ClientWidth, pbDraw.ClientHeight);
  pbDraw.Canvas.Draw(0, 0, ScrBitmap);
  Caption := 'Визуализатор';
  Application.Title := Caption;
end;

procedure TfmMain.FormDestroy(Sender: TObject);
begin
  DeleteBitmap();
end;

procedure TfmMain.FormResize(Sender: TObject);
begin
  ReCreateBitmap(pbDraw.ClientWidth, pbDraw.ClientHeight);
  pbDraw.Canvas.Draw(0, 0, ScrBitmap);
end;

procedure TfmMain.RestrictSize(var msg: TMessage);
var
  p: PMinMaxInfo;
begin
  // Ограничитель размеров окна (обработка сообщений Windows).
  // Удобная вещь кстати (важно: см. объявление процедуры в классе TFmMain)
  p := PMinMaxInfo(Msg.lParam);
  p.ptMinTrackSize.x := 520;
  p.ptMinTrackSize.y := 240;
end;

procedure TfmMain.pbDrawPaint(Sender: TObject);
begin
  pbDraw.Canvas.Draw(0, 0, ScrBitmap);
end;

Пример работы с данной конструкцией

  • SX - текущий размер нашего "экрана" по горизонтали
  • SY - по вертикали
  • TBig(Scr^). Scr - это указатель на массив пикселей битмапа, который в нашем случае имеет разрядность 32 (32 бита, или 4 байта на пиксел, что эквивалентно типу Integer. См. объявление типа TBig).

Конструкция TBig(Scr^) позволяет адресовать эту память как массив пиксел. Чтобы получить доступ к пикселу нужно использовать индекс массива [x + y * SX].

Функция RGB

Это стандартная делфяцкая функция, не приспособленная для того что мы тут творим, а только для своего "родного" класс TCanvas и его цветовых кодов. В Windows при использовании 32-разрядных битмапов формат пиксела такой (начиная с первого байта):

BBBBBBB GGGGGGGG RRRRRRRR ********

В Delphi (то что ВСЕГДА возвращает функция RGB, при любой разрядности картинки):

RRRRRRRR GGGGGGGG BBBBBBBB ******** 

Усматривается аналогия :) Все что нужно это просто перечислить аргументы функции в обратном порядке :))

Big(Scr^)[x + y * SX] := RGB(B, G, R);

B, G, R - соответственно значения интенсивности синего, зеленого, и красного цветов размером байт, т.е. [0..255].

Палитра 32-разрядным режимом не поддерживается, за нас думает Windows (вернее, понятия палитры в таком режиме вообще нет). Ну а нам остается это все юзать как надо +)))

Чтобы почистить виртуальный экран, нужно сделать так: ZeroMemory(Scr, SX * SY * 4);

procedure TfmMain.Timer1Timer(Sender: TObject);
var
  x, y: Integer;
begin
  // В цикле рисуется полная левота. Рисуйте тут свою левоту :)
  for x := 0 to SX - 1 do
    for y := 0 to SY - 1 do
      TBig(Scr^)[x + y * SX] := RGB(Random(256), Random(256), Random(256));
  // При желании, используем средства Delphi на объекте ScrBitmap типа TBitmap
  // в т.ч. можно нарисовать на нем другой Bitmap с помощью функции
  // ScrBitmap.Canvas.Draw(x,y,AnotherBitmap);
  // Чтобы текст выглядел красивее (без фона), раскомментируйте строки
  // SetBkMode(ScrBitmap.Canvas.Handle, TRANSPARENT);
  ScrBitmap.Canvas.Font.Size := 24;
  ScrBitmap.Canvas.TextOut(10, 10, 'Demo');
  // SetBkMode(ScrBitmap.Canvas.Handle, OPAQUE);
  // Нарисуемся
  pbDrawPaint(Self);
end;

В примере я (Мироводин Дмитрий) добавил вывод значения FPS, и несколько заменил процедуру заполнения массива пикселями. Дело в том, что функция Random является достаточно долгой по времени выполнения (причем всегда с разным) и по этому я заменил ее на более простую - TBig(Scr^)[x + y * SX] := RGB(254,200,23); Т.е. простая "заливка". При таком подходе Вы можете оценить реальную скорость работы цепочки заполнение памяти - отрисовка.

Итак значения примерно следующие:

полный экран 800x600 - 70-80 ms
с использованием Random - 100-120 ms

Greetz to: Vano aka RIS, Uras aka Assargadon
Special thanx to: Leon the Trillennium

Проект Delphi World © Выпуск 2002 - 2024
Автор проекта: USU Software
Вы можете выкупить этот проект.