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

Курс видеоуроков программирования и крэкерства 6.0
(актуальность: февраль 2017)
Свежие инструменты, новые видеоуроки!

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

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

БОЛЬШОЙ FAQ ПО DELPHI



Пример быстрой работы с графикой

Автор: Koster

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


 // © Koster < mtaurus@rambler.ru >
 // Greetz to: Vano aka RIS, Uras aka Assargadon
 // Special thanx to: Leon the Trillennium
 
 unit VisualForm;
 
 interface
 
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, ExtCtrls, Buttons, ComCtrls;
 
 type
   TfmMain = class(TForm)
     Panel1: TPanel;
     Panel2: TPanel;
     pbDraw: TPaintBox;
     Timer1: TTimer;
     Label1: TLabel;
     procedure FormCreate(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
     procedure FormResize(Sender: TObject);
     procedure Timer1Timer(Sender: TObject);
   private
     { Private declarations }
     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;
   public
     { Public declarations }
   end;
 
 var
   fmMain: TfmMain;
 
 implementation
 
 {$R *.DFM}
 
 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)
   // The lParam contains a pointer on a structure of type TMinMaxInfo
   p := PMinMaxInfo(Msg.lParam);
   // This represents the size of the Window when Maximized
 //  p.ptMaxSize.x := 320;
 //  p.ptMaxSize.y := 240;
   // This represents the position of the Window when Maximized
 //  p.ptMaxPosition.x := 10;
 //  p.ptMaxPosition.y := 10;
   // This represents the minimum size of the Window
   p.ptMinTrackSize.x := 520;
   p.ptMinTrackSize.y := 240;
   // This represents the maximum size of the Window
 //  p.ptMaxTrackSize.x := 400;
 //  p.ptMaxTrackSize.y := 320;
 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-разрядных битмапов формат пиксела такой (начиная с первого байта):

             BBBBBBBB GGGGGGGG RRRRRRRR ********
 

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

             RRRRRRRR GGGGGGGG BBBBBBBB ********
 

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

             TBig(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;
 
 end.
 




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



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



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


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