Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue33/undo/GraphWin.pas

Pascal/Delphi Source File | 1998-02-17 | 10.4 KB | 385 lines

unit GraphWin;

{ This unit contains code for an undoable graphics window.

  Author : Warren Kovach ([e-mail])
  Published in The Delphi Magazine }

interface

uses wintypes, winprocs, Classes, Graphics, Forms, Controls, Undo, ExtCtrls, Buttons,
     SysUtils, Dialogs;

{$IFDEF WIN32}
  {$IFDEF VER90}
const
  {$ELSE}
resourcestring
  {$ENDIF}
{$ELSE}
const
{$ENDIF}
  sLine = 'line';
  sEllipse = 'ellipse';
  sRound = 'rounded rectangle';
  sRectangle = 'rectangle';
  sShapeUndoDescr = 'Undo last %s drawn';
  sShapeShortUndoDescr = 'Undo %s';
  sShaperedoDescr = 'Redo last %s drawn';
  sShapeShortRedoDescr = 'Redo %s';
  sShapeUndoMenu = '&Undo %s';
  sShapeRedoMenu = '&Redo %s';


type
  TDrawingTool = (dtLine, dtRectangle, dtEllipse, dtRoundRect);

  TDrawShapeUndoItem = class(TUndoItem)
    private
      Location : TRect;
      DrawingTool : TDrawingTool;
      Canvas : TCanvas;
    protected
      procedure DoDrawing; virtual;
      function ShapeString : string; virtual;
      function GetUndoDescription : string; override;
      function GetShortUndoDescription : string; override;
      function GetRedoDescription : string; override;
      function GetShortRedoDescription : string; override;
      function GetUndoMenuText : string; override;
      function GetRedoMenuText : string; override;
    public
      constructor Create(ACanvas : TCanvas; ALocation : TRect;
                         ATool : TDrawingTool);
      procedure DoCommand; override;
      procedure Undo; override;
      procedure Redo; override;
  end;

  TDrawLineUndoItem = class(TDrawShapeUndoItem)
    private
      PointList : TList;
      procedure AddPointToList(P : TPoint);
    protected
      procedure DoDrawing; override;
      function ShapeString : string; override;
    public
      constructor Create(ACanvas : TCanvas; ALocation : TRect;
                         ATool : TDrawingTool);
      destructor Destroy; override;
      procedure AddSegment(NextPoint : TPoint);
      procedure Undo; override;
      procedure Redo; override;
  end;

  TGraphicWindow = class(TUndoForm)
    Panel1: TPanel;
    LineButton: TSpeedButton;
    RectangleButton: TSpeedButton;
    EllipseButton: TSpeedButton;
    RoundRectButton: TSpeedButton;
    Image1: TImage;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure EllipseButtonClick(Sender: TObject);
    procedure LineButtonClick(Sender: TObject);
    procedure RectangleButtonClick(Sender: TObject);
    procedure RoundRectButtonClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
    DrawingTool: TDrawingTool;
    MouseMoved,
    LineDrawing : boolean;
  public
    { Public declarations }
  end;

var
  GraphicWindow : TGraphicWindow;

implementation

{$R *.DFM}

constructor TDrawShapeUndoItem.Create(ACanvas : TCanvas; ALocation : TRect;
                                      ATool : TDrawingTool);
begin
  inherited Create;
  Location := ALocation;
  DrawingTool := ATool;
  Canvas := ACanvas;
end;

procedure TDrawShapeUndoItem.DoDrawing;
begin
  with Canvas,Location do begin
    Pen.Mode := pmNotXOR;
    case DrawingTool of
      dtLine: begin
                MoveTo(Right,Top);
                LineTo(Left,Bottom);
              end;
      dtRectangle: Rectangle(Left,Top,Right,Bottom);
      dtEllipse:   Ellipse(Left,Top,Right,Bottom);
      dtRoundRect: RoundRect(Left,Top,Right,Bottom,
                            (Left-Right) div 2,(Top-Bottom) div 2);
    end;
  end;
end;

procedure TDrawShapeUndoItem.DoCommand;
begin
  DoDrawing;
end;

procedure TDrawShapeUndoItem.Undo;
begin
  DoDrawing;
end;

procedure TDrawShapeUndoItem.Redo;
begin
  DoCommand;
end;

function TDrawShapeUndoItem.ShapeString : string;
begin
  case DrawingTool of
    dtLine: Result := sLine;
    dtRectangle: Result := sRectangle;
    dtEllipse:   Result := sEllipse;
    dtRoundRect: Result := sRound;
  end;
end;

function TDrawShapeUndoItem.GetUndoDescription : string;
begin
  Result := Format(sShapeUndoDescr,[ShapeString]);
end;

function TDrawShapeUndoItem.GetShortUndoDescription : string;
begin
  Result := Format(sShapeShortUndoDescr,[ShapeString]);
end;

function TDrawShapeUndoItem.GetRedoDescription : string;
begin
  Result := Format(sShapeRedoDescr,[ShapeString]);
end;

function TDrawShapeUndoItem.GetShortRedoDescription : string;
begin
  Result := Format(sShapeShortRedoDescr,[ShapeString]);
end;

function TDrawShapeUndoItem.GetUndoMenuText : string;
begin
  Result := Format(sShapeUndoMenu,[ShapeString]);
end;

function TDrawShapeUndoItem.GetRedoMenuText : string;
begin
  Result := Format(sShapeRedoMenu,[ShapeString]);
end;
{ -------------------------------------------------------- }

constructor TDrawLineUndoItem.Create(ACanvas : TCanvas; ALocation : TRect;
                                     ATool : TDrawingTool);
begin
  inherited Create(ACanvas,ALocation,ATool);
  PointList := TList.Create;
end;

destructor TDrawLineUndoItem.Destroy;
begin
  PointList.Free;
  inherited Destroy;
end;

procedure TDrawLineUndoItem.AddPointToList(P : TPoint);
{ we can add 4-byte values to a TList by typecasting them
  as pointers, then typecasting back to native type when
  read back. The x and y of a 16-bit TPoint are integers
  (2 bytes each) whereas in 32-bit they are longints (4
  bytes) so they must be done separately }
begin
{$IFDEF Win32}
  PointList.Add(pointer(p.x));
  PointList.Add(pointer(p.y));
{$ELSE}
  PointList.Add(pointer(p));
{$ENDIF}
end;

procedure TDrawLineUndoItem.DoDrawing;
begin
  with Canvas,Location do begin
    Pen.Mode := pmNotXOR;
    MoveTo(Left,Top);
    AddPointToList(TopLeft);
  end;
end;

procedure TDrawLineUndoItem.AddSegment(NextPoint : TPoint);
begin
  with Canvas do begin
    Pen.Mode := pmNotXOR;
    LineTo(NextPoint.x,NextPoint.y);
  end;
  AddPointToList(NextPoint);
end;

procedure TDrawLineUndoItem.Undo;
var
  i : integer;
  P : pointer;
{$IFDEF Win32}
  Point : TPoint;
{$ENDIF}
begin
{ a faster method for redoing is to store points in an array
  of TPoints, then pass that to Polyline. Unfortunately, it is
  difficult to do that in a dynamic fashion, creating
  an array just large enough to hold the points. Can use the method
  of declaring a pointer to an array type of the maximum size
  (8192 under Delphi1),
  then using GetMem to allocate just enough memory. Unfortunately,
  if this is passed to Polygon it thinks it is suposed to use the
  full 8192 elements, not just those allocated. Can use Slice to
  make array just the right size, but this isn't available in Delphi 1.
  In the end, TList is easier since it automatically grows in size when
  needed, whereas with our own dynamically allocated array we
  would have to take care of resizing ourselves, since we don't
  know how big we will need to be until mouse button is released.
}
  with Canvas do begin
    Pen.Mode := pmNotXOR;
{$IFDEF Win32}
    { can't typecast property directly, must copy to a variable }
    P := PointList[0];
    Point.X := Longint(P);
    P := PointList[1];
    Point.y := Longint(P);
    with Point do Moveto(x,y);
    for i := 2 to pred(PointList.Count) do begin
      P := PointList[i];
      if Odd(i) then begin
        Point.y := Longint(P);
        with Point do LineTo(x,y);
      end
      else
        Point.X := Longint(P);
    end;
{$ELSE}
    P := PointList[0];
    with TPoint(P) do Moveto(x,y);
    for i := 1 to pred(PointList.Count) do begin
      P := PointList[i];
      with TPoint(P) do LineTo(x,y);
    end;
{$ENDIF}
  end;
end;

procedure TDrawLineUndoItem.Redo;
begin
  Undo;
end;

function TDrawLineUndoItem.ShapeString : string;
begin
  Result := sLine;
end;

{ -------------------------------------------------------- }
procedure TGraphicWindow.FormCreate(Sender: TObject);
begin
  LineDrawing := false;
  MouseMoved := false;
end;

procedure TGraphicWindow.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caFree;
end;

procedure TGraphicWindow.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  Item : TUndoItem;
begin
  MouseMoved := false;
  Case Button of
    mbLeft  : begin
                if DrawingTool = dtLine then begin
                  LineDrawing := true;
                  Item := TDrawLineUndoItem.Create(Image1.Canvas,
                                Rect(x,y,x,y),DrawingTool);
                end
                else
                  Item := TDrawShapeUndoItem.Create(Image1.Canvas,
                                Rect(x,y,x+50,y+50),DrawingTool);
                if UndoStack.Submit(Item) = ssFull then
                  ShowMessage(Format(sStackFull,[UndoStack.MaxItems]));
              end;

    mbMiddle : begin
                UndoStack.Redo(1);
               end;
    mbRight : begin
                UndoStack.Undo(1);
              end;
  end;
end;

procedure TGraphicWindow.Image1MouseMove(Sender: TObject; Shift: TShiftState;
  X, Y: Integer);
begin
  if LineDrawing then begin
    MouseMoved := true;
    with UndoStack.CurrentItem as TDrawLineUndoItem do
      AddSegment(Point(x,y));
  end;
end;

procedure TGraphicWindow.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if LineDrawing and (Button = mbLeft) then begin
    if MouseMoved = false then
      UndoStack.RemoveLastItem
    else with UndoStack.CurrentItem as TDrawLineUndoItem do
      AddSegment(Point(x,y));
    LineDrawing := false;
    MouseMoved := false;
  end;
end;

procedure TGraphicWindow.EllipseButtonClick(Sender: TObject);
begin
  DrawingTool := dtEllipse;
end;

procedure TGraphicWindow.LineButtonClick(Sender: TObject);
begin
  DrawingTool := dtLine;
end;

procedure TGraphicWindow.RectangleButtonClick(Sender: TObject);
begin
  DrawingTool := dtRectangle;
end;

procedure TGraphicWindow.RoundRectButtonClick(Sender: TObject);
begin
  DrawingTool := dtRoundRect;
end;

end.