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

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.  

Добавлено: 25 Июля 2018 08:44:33 Добавил: Андрей Ковальчук Нравится 0

Добавить