dynamic painting in Delphi

Dynamic Drawing in Delphi

Introduction
This article describes a method for smooth, flicker free, drawing.
Please refer to figure 1. below:

fig.1

On a paintbox a line with arrow is drawn.
This is done by moving the mousepointer over the paintbox,
pressing down (and holding) the left mousebutton at point 1,
moving the pointer to point 2, where the mousebutton is released.

General Description
The affected rectangle of the paintbox is marked by a purple line.
Outside this rectangle, no changes took place.
While the mousebutton is down and the mouse is moving, a new line must
painted after each mouse-move. So, at each mouse-move, we have to

Erasing may be done by repainting the effected rectangle.
But by painting directly in the paintbox, erasing and repainting causes flickering,
which is very unpleasant to the eyes.

A better way is to paint in a Bitmap and copy only the changes to the paintbox.
While painting in this bitmap, during the paint process old images have to be erased
before the new image, representing the new position, can be painted.
So, we add another bitmap, which holds the unchanged image and thus can be used
to restore parts of the bitmap we use for painting.
Restoring is conveniently done by procedure

bitmap2.canvas.copyrect(pRect,bitmap1.canvas,pRect) where pRect is the affected area that needs restoring.

See figure 2.

fig.2

We notice bitmap1 and bitmap2.
Bitmap1 holds the background and original image: the results of previous paint operations.
Trial painting takes place in bitmap2.
During the trial painting in bitmap2, after each mouse-move rectangles are

When painting in bitmap2 is finished (on release of the mousebutton), the image may be painted
in bitmap1 to become permanent.

Looking more in detail we note, that the affected rectangle to be copied to the paintbox is the union of

To control this process, we introduce 2 rectangles (Trect) :

drawrect

boxrect

Also we introduce boolean variable boxflag.
After copying bitmap2 to the paintbox, boxflag is set to false, indicating paintbox1 is updated.
After restoring or painting in bitmap2, boxrect is set to the rectangle of change.
However:
if boxflag is false then the rectangle is simply copied to boxrext and boxflag is set true
if boxflag is true, then the rectangle of change is included with the existing rectangle to
indicate the total area of change.

So, this happens when mouse-move events take place

drawrect

boxrect

drawrect

boxrect

Handling the Mouse-Events
During the paint process following conditions occur:

A counter Pcontrol is used to reflect the above states, Pcontrol =

The Program
Procedure DrawControl receives all events.
For the drawing it selects the appropriate drawing procedure.
Variable pBitmap (TBitmap) is the bitmap to be used by the drawing procedures.
The (x,y) coordinates from the mouse-events are saved in (px1,px2) at first and later in (px2,py2)
Function XY2Rect : Trect , converts px1,py1,px2,py2 to the rectangle format.
Function UniRect(rect1,rect2) : Trect , calculates the union of rect1 , rect2.

mainbtn is a davarrayButton to select various draw operations : line, rectangle, ellipse.
Variable mainbutton reflects the state of mainbtn
For more details, please refer to the comments in the full program listing below:
All procedures are kept simple and straightforward, to show the basic priciples.

Program Listing

Untitled

unit Unit1;
{
 smooth, flicker free, drawing demo
}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  davArrayBtn, ExtCtrls;

type
  TForm1 = class(TForm)
    DavArrayBtn1: TDavArrayBtn;
    PaintBox1: TPaintBox;
    procedure DavArrayBtn1BtnPaint(sender: TObject; BtnNr: Byte;
      status: TBtnStatus);
    procedure FormCreate(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure DavArrayBtn1BtnChange(sender: TObject; BtnNr: Byte;
      status: TBtnStatus; button: TMouseButton);
    procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure restore(r : Trect);forward;
procedure drawswitch;forward;
function UniRect(r1,r2 : Trect) : Trect;forward;
procedure map2box;forward;
procedure initmaps;forward;
function XY2Rect(x1,y1,x2,y2 : integer) : Trect;forward;
procedure UpdateBoxrect(r : Trect);forward;

type TMain = (mbClear,mbLine,mbRectangle,mbEllipse,mbOff);//main menu states
     TmsEvent = (msDown,msMove,msUp);  //mouse events

var bitmap1,bitmap2,pMap : TBitmap;
    mainbutton : Tmain = mbOff;     //select drawing operation
    Pcontrol : byte;                //drawing control counter
    boxrect,drawrect : Trect;
    boxflag : boolean = false;
    px1,py1,px2,py2 : integer;      //coordinates from mouse events

procedure DrawControl(ms : TmsEvent; x,y : integer);
//receives mouse events, controls drawing
begin
 case ms of 
   msDown : if Pcontrol = 0 then
             begin
              Pcontrol := 1;
              Pmap := bitmap2;     //paint in bitmap2
              px1 := x; py1 := y;  //save coordinates
             end;
   msMove : begin
             if Pcontrol = 2 then restore(drawrect);  //restore previous drawing
             if Pcontrol = 1 then Pcontrol := 2;
             if Pcontrol <> 0 then
              begin
               px2 := x; py2 := y;
               drawswitch;        //select drawing proc, make drawrect
               UpdateBoxRect(drawrect);
               map2box;           //show drawing changes in boxrect
              end;
            end;
   msUp   : begin
             if Pcontrol = 2 then
              begin
               Pmap := bitmap1;
               drawswitch;
               restore(drawrect);
               map2box;
              end;
             Pcontrol := 0;
            end;
 end;//case
end;

procedure lineproc;
//paint a red line
begin
 with Pmap do with canvas do
  begin
   pen.color := $0000ff;
   moveto(px1,py1);
   lineto(px2,py2);
  end;
end;

procedure rectproc;
//paint a green rectangle
begin
 with Pmap do with canvas do
  begin
   pen.color := $00c000;
   brush.style := bsClear;
   rectangle(px1,py1,px2,py2);
  end;
end;

procedure ellipseproc;
//paint a blue ellipse
begin
 with Pmap do with canvas do
  begin
   pen.color := $ff0000;
   brush.style := bsclear;
   ellipse(px1,py1,px2,py2);
  end;
end;

procedure TForm1.DavArrayBtn1BtnChange(sender: TObject; BtnNr: Byte;
  status: TBtnStatus; button: TMouseButton);
//main menu button change
begin
 with davarrayBtn1 do
  begin
   if status <> stDown then mainbutton := mbOff
    else
     begin
      mainbutton := Tmain(BtnNr);
      case mainbutton of
       mbClear : begin
                  initmaps;
                  Pcontrol := 0;
                  boxflag := false;
                  BtnRelease(byte(mainbutton));
                 end;
       mbLine  : ;
       mbRectangle : ;
       mbEllipse : ;
      end;//case
     end;
  end;//with
end;

procedure drawswitch;
//select proper drawing procedure, make drawrect
begin
 drawrect := XY2Rect(px1,py1,px2,py2);
 with drawrect do
  begin
   left := left -1;
   right := right + 1;
   top := top - 1;
   bottom := bottom + 1;
  end;
 if boxflag then boxrect := UniRect(boxrect,drawrect)
  else begin
        boxrect := drawrect;
        boxflag := true;
       end;  
 case mainbutton of
  mbLine      : lineproc;
  mbRectangle : rectproc;
  mbEllipse   : EllipseProc;
 end;
end;

procedure UpdateBoxrect(r : Trect);
begin
 if boxflag then boxrect := UniRect(boxrect,r)  //union of rectangles
  else begin
        boxrect := r;
        boxflag := true;
       end;
end;

procedure restore(r : Trect);
//restore r area of bitmap2
begin
 bitmap2.canvas.CopyRect(r,bitmap1.canvas,r);
 UpdateBoxRect(r);
end;

procedure map2box;
begin
 form1.paintbox1.canvas.copyrect(boxrect,bitmap2.canvas,boxrect);
 boxflag := false; //paintbox update done
end;

function UniRect(r1,r2 : Trect) : Trect;
//union of rectangles
begin
 with result do
  begin
   if r1.left   < r2.left   then left   := r1.left   else left   := r2.Left;
   if r1.top    < r2.top    then top    := r1.top    else top    := r2.top;
   if r1.right  > r2.right  then right  := r1.right  else right  := r2.right;
   if r1.bottom > r2.bottom then bottom := r1.bottom else bottom := r2.bottom;
  end;
end;

function XY2Rect(x1,y1,x2,y2 : integer) : Trect;
//make rectangle out of coordinates
begin
 with result do
  begin
   if x1 < x2 then begin
                    left := x1; right := x2;
                   end
   else begin
         left := x2; right := x1;
        end;
   if y1 < y2 then begin
                    top := y1; bottom := y2;
                   end
   else begin
         top := y2; bottom := y1;
        end;
  end;//with
end;

procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
 drawControl(msDown,x,y);
end;

procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
 drawControl(msMove,x,y);
end;

procedure TForm1.PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
 drawControl(msUp,x,y);
end;

procedure TForm1.DavArrayBtn1BtnPaint(sender: TObject; BtnNr: Byte;
  status: TBtnStatus);
const dtext : array[0..3] of string =
              ('clear','line','rectangle','ellipse');
var r : Trect;
    x,y : integer;
begin
 with davarrayBtn1 do with canvas do
  begin
   if status = stHI then font.style := [fsBold] else font.style := [];
   r := getBtnRect(BtnNr);
   x := r.left + (btnWidth - textwidth(dtext[btnNr])) div 2;
   y := r.top + (btnheight - textheight(dtext[btnNr])) div 2;
   textout(x,y,dtext[BtnNr]);
  end;
end;

procedure initmaps;
//paint grid in bitmap1, copy to bitmap2
var i : integer;
begin
 with bitmap1 do with canvas do
  begin
   brush.color := $e0ffff;
   brush.style := bsSolid;
   pen.color := $fff0f0;
   fillrect(rect(0,0,width,height));
   pen.Width := 1;
   i := 0;
   while i < width do
    begin
     moveto(i,0); lineto(i,height);
     inc(i,20);
    end;
   i := 0;
   while i < height do
    begin
     moveto(0,i); lineto(width,i);
     inc(i,20);
    end;
  end;
 bitmap2.canvas.draw(0,0,bitmap1);
 form1.paintbox1.invalidate;
end;
  
procedure TForm1.FormCreate(Sender: TObject);
begin
 with davArrayBtn1.canvas do
  begin
   font.height := 20;
  end;
 bitmap1 := TBitmap.create;
 with bitmap1 do
  begin
   width := paintbox1.width;
   height := paintbox1.height;
   pixelformat := pf32bit;
  end;
 bitmap2 := TBitmap.create;
 with bitmap2 do
  begin
   width := paintbox1.width;
   height := paintbox1.height;
   pixelformat := pf32bit;
  end;
 pMap := nil;
 initmaps;
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
 paintbox1.canvas.draw(0,0,bitmap2);
end;

procedure TForm1.FormPaint(Sender: TObject);
//paint edge around paintbox
var x1,y1,x2,y2 : integer;
begin
 with paintbox1 do
  begin
   x1 := left-1;
   y1 := top-1;
   x2 := left+width;
   y2 := top + height;
  end;
 with canvas do
  begin
   pen.color := $303030;
   pen.width := 1;
   moveto(x1,y1); lineto(x1,y2);
   lineto(x2,y2); lineto(x2,y1); lineto(x1,y1);
  end; 
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 bitmap1.free;
 bitmap2.free;
end;

end.

OneStat