Форум: "Начинающим";
Текущий архив: 2008.03.30;
Скачать: [xml.tar.bz2];

Вниз

Подскажите как рисовать на форме без мерцания?   Найти похожие ветки 

← →
<code>   (2008-03-02 14:33) [0]

Вот код:


unit Unit1; {$o-}
interface

uses   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,  ExtCtrls, StdCtrls;

type
 TForm1 = class(TForm)
   procedure FormCreate(Sender: TObject);
   procedure FormClose(Sender: TObject; var Action: TCloseAction);
   procedure FormPaint(Sender: TObject);
   procedure FormMouseDown(Sender: TObject; Button: TMouseButton;       Shift: TShiftState; X, Y: Integer);
   procedure FormMouseUp(Sender: TObject; Button: TMouseButton;         Shift: TShiftState; X, Y: Integer);
   procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);

 private     { Private declarations }
 public      { Public declarations }
 end;

type TVarData = class
ARR:Array[0..39,0..39] of integer;
Mul:integer;
Size:Integer;
Left:Integer;
Top:Integer;
MouseDown:byte;
end;

var   Form1: TForm1;   VD:TVarData;     BitMap:TBitmap;

implementation {$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var i,a,b:integer;                              
begin
 OnMouseDown:=FormMouseDown;
 OnMouseMove:=FormMouseMove;
 OnMouseUp:=FormMouseUp;
 OnPaint:=FormPaint;
 OnClose:=FormClose;

 VD:=TVarData.Create;
 VD.Mul:=16;
 VD.Size:=15;
 VD.Left:=0;
 VD.Top:=0;
 Width:=VD.Mul*40+VD.Left*2+7;
 Height:=VD.Mul*40+VD.Top*2+27;

       for a:=0 to 39 do
       begin
         for b:=0 to 39 do
           begin
             VD.ARR[a,b]:=$FF0000;
           end;
     end;

 for i:=1 to 38 do VD.ARR[i,5]:=$00FF00;

BitMap := TBitmap.Create;
Bitmap.Width := Form1.Width;
Bitmap.Height := form1.Height;
Bitmap.Canvas.Brush.Color := clBlack;

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
 VD.Free;
 BitMap.Free;
end;

procedure TForm1.FormPaint(Sender: TObject);
var a,b:byte;   Rect: TRect;
begin
       for a:=0 to 39 do
       begin
         for b:=0 to 39 do
           begin
            //Canvas.Brush.Color:=VD.ARR[a,b];
            BitMap.Canvas.Brush.Color:=VD.ARR[a,b];

            Rect.Left:=a*VD.Mul+VD.Left;
            Rect.Top:=b*VD.Mul+VD.top;
            Rect.Right:=a*VD.Mul+VD.size+VD.Left;
            Rect.Bottom:=b*VD.Mul+VD.size+VD.top;

            BitMap.Canvas.FillRect(Rect);

            //Canvas.FillRect(Rect);
           end;
     end;

                  Form1.Canvas.Draw(0,0,Bitmap);
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;   Shift: TShiftState; X, Y: Integer);
begin
 if Button=mbLeft then VD.MouseDown:=1 else if Button=mbRight then VD.MouseDown:=10;

   if  VD.MouseDown=1 then
 begin
   VD.ARR[(X-VD.Left) div VD.Mul,(Y-VD.Top) div VD.Mul]:=$00FF00;
   Repaint;
 end
   else
        if  VD.MouseDown=10 then
        begin
          VD.ARR[(X-VD.Left) div VD.Mul,(Y-VD.Top) div VD.Mul]:=$FF0000;
          Repaint;
        end;

end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;   Shift: TShiftState; X, Y: Integer);
begin
 VD.MouseDown:=0;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,  Y: Integer);
begin
 if  VD.MouseDown=1 then
 begin
   VD.ARR[(X-VD.Left) div VD.Mul,(Y-VD.Top) div VD.Mul]:=$00FF00;
   Repaint;
 end
   else
        if  VD.MouseDown=10 then
        begin
          VD.ARR[(X-VD.Left) div VD.Mul,(Y-VD.Top) div VD.Mul]:=$FF0000;
          Repaint;
        end;
end;

end.


При рисовании мышью всё сильно мерцает. Как сэтим бороться?

---

← →
{RASkov} ©   (2008-03-02 14:55) [1]

> [0]   (02.03.08 14:33)

procedure TForm1.FormCreate(Sender: TObject);
....
begin
 ................
 DoubleBuffered:=True;
end;

---

← →
<code>   (2008-03-02 14:59) [2]

У меня нет DoubleBuffered, у меня Delphi 3. А как-нибудь ещё можно избавится от мерцания?

---

← →
{RASkov} ©   (2008-03-02 15:33) [3]

> [2]   (02.03.08 14:59)

Сорри... не обратил внимания...
Ну тогда примерно так:
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,  Y: Integer);
var R: TRect;
begin
if  VD.MouseDown=1 then
begin
  VD.ARR[(X-VD.Left) div VD.Mul,(Y-VD.Top) div VD.Mul]:=$00FF00;
  R:=Rect(X-VD.Size, Y-VD.Size, X+VD.Size, Y+VD.Size);
  InvalidateRect(Handle, @R, False);
end
  else
       if  VD.MouseDown=10 then
       begin
         VD.ARR[(X-VD.Left) div VD.Mul,(Y-VD.Top) div VD.Mul]:=$FF0000;
         R:=Rect(X-VD.Size, Y-VD.Size, X+VD.Size, Y+VD.Size);
         InvalidateRect(Handle, @R, False);
       end;
end;

Вообщем R расчитай как нужно, а не так как я.... лень считать, да и математика у меня - горе :(

---

← →
{RASkov} ©   (2008-03-02 15:36) [4]

И кто тебя так форматировать код учил :( ужас...

---

← →
<code>   (2008-03-02 16:21) [5]

Спасибо, работает без мерцания!

---

← →
{RASkov} ©   (2008-03-02 18:49) [6]

> [5]   (02.03.08 16:21)

Делать было нечего... Попробуй еще вот такой вариант: (без дополнительно битмапа)
unit Unit1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms;

const CLR_CLEAR = $FF0000;
     CLR_CELL  = $00FF00;

type
 TCellsData = record
  ARR: array [0..39, 0..39] of Integer;
  CellSize, GridWidth: Integer; //Размер ячейки и ширина линий сетки
 end;

 TForm1 = class(TForm)
   procedure FormCreate(Sender: TObject);
   procedure FormPaint(Sender: TObject);
   procedure FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
   procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
 private
   VD: TCellsData;
   procedure PaintCell(ACol, ARow: Integer);
   procedure TestPaintCell(X, Y: Integer; const IsErase: Boolean);
   { Private declarations }
 public      { Public declarations }
 end;

var Form1: TForm1;

implementation {$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var C, R: Integer;
begin
 OnMouseDown:=FormMouseDown;
 OnMouseMove:=FormMouseMove;
 OnPaint:=FormPaint;

 VD.CellSize:=15;
 VD.GridWidth:=1;
 ClientWidth:=(VD.CellSize+VD.GridWidth)*Length(VD.ARR)+VD.GridWidth;
 ClientHeight:=(VD.CellSize+VD.GridWidth)*Length(VD.ARR[0])+VD.GridWidth;

 for C:=Low(VD.ARR) to High(VD.ARR) do
  for R:=Low(VD.ARR[C]) to High(VD.ARR[C]) do VD.ARR[C, R]:=CLR_CLEAR;

 for C:=Succ(Low(VD.ARR)) to Pred(High(VD.ARR)) do VD.ARR[C, 5]:=CLR_CELL;
end;

//Прорисовка ячейки с координатами ACol и ARow
procedure TForm1.PaintCell(ACol, ARow: Integer);
var Rct: TRect;
begin
 Canvas.Brush.Color:=VD.ARR[ACol, ARow];
 with Rct do begin
  Left:=VD.GridWidth+ACol*(VD.CellSize+VD.GridWidth);
  Top:=VD.GridWidth+ARow*(VD.CellSize+VD.GridWidth);
  Right:=Left+VD.CellSize;
  Bottom:=Top+VD.CellSize;
 end;
 Canvas.Rectangle(Rct);
end;

//Отрисовка всей сетки
procedure TForm1.FormPaint(Sender: TObject);
var C, R: Byte;
begin
 for C:=Low(VD.ARR) to High(VD.ARR) do
  for R:=Low(VD.ARR[C]) to High(VD.ARR[C]) do PaintCell(C, R);
end;

//Проверка на необходимость перерисовки ячейки
procedure TForm1.TestPaintCell(X, Y: Integer; const IsErase: Boolean);
var C, R: Integer;
begin
 //Проверка принадлежности X и Y ячейки. Если не попадает - выход
 if not((X mod (VD.CellSize+VD.GridWidth)>VD.GridWidth)
    and (Y mod (VD.CellSize+VD.GridWidth)>VD.GridWidth)) then Exit;
 //Определение ячейки по X и Y
 C:=X div (VD.CellSize+VD.GridWidth);
 R:=Y div (VD.CellSize+VD.GridWidth);
 //Проверка диапазона
 if (C<Low(VD.ARR))or(C>High(VD.ARR))or(R<Low(VD.ARR[C]))or(R>High(VD.ARR[C])) then Exit;
 //Проверка на необходимость закрашивания/стирания. Если не нужно - выход
 if IsErase then
  if VD.ARR[C, R]<>CLR_CLEAR then VD.ARR[C, R]:=CLR_CLEAR else Exit
 else
  if VD.ARR[C, R]<>CLR_CELL then VD.ARR[C, R]:=CLR_CELL else Exit;
 //Отрисовываем ячейку
 PaintCell(C, R);
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
 if (Button=mbLeft) or (Button=mbRight) then TestPaintCell(X, Y, Button=mbRight);
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,  Y: Integer);
begin
if (ssLeft in Shift) or (ssRight in Shift) then TestPaintCell(X, Y, ssRight in Shift);
end;

end.
...если конечно заглянешь еще в свою ветку)

---

← →
<code>   (2008-03-02 21:06) [7]

>Попробуй еще вот такой вариант: (без дополнительно битмапа)

Да, без битмапа лучше.

---

Страницы: 1 вся ветка

Форум: "Начинающим";
Текущий архив: 2008.03.30;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.48 MB
Время: 0.043 c