drawbox.pas

A diagram edit component for delphi/c++ builder with full source included

unit DrawBox;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls,Contnrs,Printers,Math,Comctrls,buttons;

type
  TRealPoint=record x,y:real; end;
  TRealRect=record left,top,right,bottom:real; end;

  TPaper=(Letter,A3,A4,A5,B4,B5,Custom);

  TAlignment=(alLeft,alHorzCenter,alRight,alTop,alVertCenter,alBottom);

  TView=class;

  TDrawObj=class(TObject)
  private
    FView:TView;

    FPoints:Array of TRealPoint;
    FPen:TPen;
    FBrush:TBrush;
    FFont:TFont;

    FSelected:boolean;
    FHandle:integer;
    FHandleCount:integer;
  public
    constructor Create;reintroduce;
    destructor Destroy;override;

    procedure Draw(Canvas:TCanvas);virtual;
    procedure DrawHandle(Canvas:TCanvas);
    procedure Move(dx,dy:Real);
    procedure HandleMove(dx,dy:Real);virtual;
    function Handles(AHandle:integer):TRealPoint;virtual;
    function Bounds:TRealRect;virtual;
    function HitTest(r:TRealRect;Canvas:TCanvas):integer;virtual;
    function GetCursor(p:TRealPoint;canvas:Tcanvas):TCursor;virtual;
    procedure Normalize;virtual;
    procedure Alignment(AAlignment:TAlignment;pos:real);virtual;
    procedure ShowProperty;virtual;

    property Handle:integer read FHandle write FHandle;
    property View:TView read FView write FView;
    property Selected:boolean read FSelected write FSelected;

  public
    property Pen:TPen read FPen write FPen;
    property Brush:TBrush read FBrush write FBrush;
    property Font:TFont read FFont write FFont;

  end;

  //TShapeType=(stRectangle,stRoundRectangle,stEllipse,stCircle);
  TRectangle=class(TDrawObj)
  private
    FShape:TShapeType;
    FText:string;
  public
    constructor Create(points:array of TRealPoint);reintroduce;
    destructor Destroy;override;

    procedure Draw(Canvas:TCanvas);override;
    function Handles(AHandle:integer):TRealPoint;override;
    procedure HandleMove(dx,dy:Real);override;
    function Bounds:TRealRect;override;
    function HitTest(r:TRealRect;Canvas:TCanvas):integer;override;
    function GetCursor(p:TRealpoint;canvas:TCanvas):TCursor;override;
    procedure Normalize;override;
    procedure Alignment(AAlignment:TAlignment;pos:real);override;
    procedure ShowProperty;override;

  public
    property Shape:TShapeType read FShape write FShape;
  end;

  TPolyLine=class(TDrawObj)
  private
    FText:string;
  public
    constructor Create(points:array of TRealPoint);reintroduce;
    destructor Destroy;override;

    procedure Draw(Canvas:TCanvas);override;
    function Handles(AHandle:integer):TRealPoint;override;
    procedure HandleMove(dx,dy:Real);override;
    function Bounds:TRealRect;override;
    function HitTest(r:TRealRect;Canvas:TCanvas):integer;override;
    function GetCursor(p:TRealpoint;canvas:TCanvas):TCursor;override;
    procedure Normalize;override;
    procedure Alignment(AAlignment:TAlignment;pos:real);override;
    procedure ShowProperty;override;

  end;

  TDrawingTool=(dtSelect,dtZoom,dtRectangle,dtEllipse,dtCircle,dtRoundRectangle,dtLine,dtPolyLine);
  TSelectMode=(smNone,smShift,smCtrl);

  TView=class(TPaintBox)
  private
    FDrawingTool:TDrawingTool;
    FDownPoint:TRealPoint;
    FUpPoint:TRealPoint;
    FMovePoint:TRealPoint;
    FTest:boolean;
    FPrinting:boolean;

    FObjects:TObjectList;

    FPaper:TPaper;
    FPaperWidth:integer;
    FPaperHeight:integer;
    FPaperColor:TColor;
    FZoom:integer;
    FShowGrid:boolean;

    function DocToView(x:Real;Canvas:TCanvas):Real;overload;
    function ViewToDoc(x:Real;Canvas:TCanvas):Real;overload;
    function DocToView(p:TRealPoint;Canvas:TCanvas):TRealPoint;overload;
    function ViewToDoc(p:TRealPoint;Canvas:TCanvas):TRealPoint;overload;
    function DocToView(r:TRealRect;Canvas:TCanvas):TRealRect;overload;
    function ViewToDoc(r:TRealRect;Canvas:TCanvas):TRealRect;overload;

    procedure SetPaper(Value:TPaper);
    procedure SetPaperWidth(Value:integer);
    procedure SetPaperHeight(Value:integer);
    procedure SetPaperColor(value:TColor);
    procedure SetZoom(value:integer);

    procedure SetShowGrid(value:boolean);

    function HitTest(p:TRealPoint;mode:TSelectMode):boolean;overload;
    function HitTest(r:TRealRect;mode:TSelectMode):boolean;overload;

    function SelectedCount:integer;
    function SelectedObj:TDrawObj;
    function GetCursor(p:TRealPoint):TCursor;

    procedure RubberBand(p1,p2:TRealPoint);
    procedure Draw(Canvas:TCanvas);
    procedure Paint;override;
    procedure InvalObj(obj:TDrawObj);
    procedure Move(dx,dy:Real);

  protected
    procedure DblClick;override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer);override;
    procedure KeyDown(var Key: Word; Shift: TShiftState);

  public
    constructor Create(AOwner:TComponent);override;
    destructor Destroy;override;

    procedure Add(obj:TDrawObj);
    procedure Delete(obj:TDrawObj);overload;
    procedure Delete(index:integer);overload;
    procedure Select(obj:TDrawObj);
    procedure Unselect(obj:TDrawObj);
    procedure SelectAll;
    procedure UnselectAll;
    procedure Print;
    procedure LoadFromFile(AFileName:String);
    procedure LoadFromStream(AStream:TStream);
    procedure SaveToFile(AFileName:String);
    procedure SaveToStream(AStream:TStream);
    procedure Alignment(AAlignment:TAlignment);
    procedure ShowProperty;

    property DrawingTool:TDrawingTool read FDrawingTool write FDrawingTool;
    property Paper:TPaper read FPaper write SetPaper;
    property PaperWidth:integer read FPaperWidth write SetPaperWidth;
    property PaperHeight:integer read FPaperHeight write SetPaperHeight;
    property PaperColor:TColor read FPaperColor write SetPaperColor;
    property Zoom:integer read FZoom write SetZoom;
    property ShowGrid:boolean read FShowGrid write SetShowGrid;
  end;

  TCustomDrawBox = class(TScrollBox)
  private
    FView:TView;
    FRightEdge,FBottomEdge:TShape;

    procedure SetDrawingTool(value:TDrawingTool);
    function GetDrawingTool:TDrawingTool;
    procedure SetPaper(value:TPaper);
    function GetPaper:TPaper;
    procedure SetPaperWidth(value:integer);
    function GetPaperWidth:integer;
    procedure SetPaperHeight(value:integer);
    function GetPaperHeight:integer;
    procedure SetPaperColor(value:TColor);
    function GetPaperColor:TColor;
    procedure SetShowGrid(value:boolean);
    function GetShowGrid:Boolean;
    procedure SetZoom(value:integer);
    function GetZoom:Integer;
    procedure SetEdgePosition;
  public
    constructor Create(AOwner:TComponent);override;
    destructor Destroy;override;

    procedure Add(obj:TDrawObj);
    procedure Delete(obj:TDrawObj);overload;
    procedure Delete(index:integer);overload;
    procedure Select(obj:TDrawObj);
    procedure Unselect(obj:TDrawObj);
    procedure SelectAll;
    procedure UnselectAll;
    procedure Print;
    procedure LoadFromFile(AFileName:String);
    procedure LoadFromStream(AStream:TStream);
    procedure SaveToFile(AFileName:String);
    procedure SaveToStream(AStream:TStream);
    procedure Alignment(AAlignment:TAlignment);

  public
    procedure PaperProperty;
    property DrawingTool:TDrawingTool read GetDrawingTool write SetDrawingTool;
    property Paper:TPaper read GetPaper write Setpaper;
    property PaperWidth:integer read GetPaperWidth write SetPaperWidth;
    property PaperHeight:integer read GetPaperHeight write SetPaperHeight;
    property PaperColor:TColor read GetPaperColor write SetPaperColor;
    property Zoom:integer read GetZoom write SetZoom;
    property ShowGrid:boolean read GetShowGrid write SetShowGrid;
  end;

  TDrawBox=class(TCustomDrawBox)
  published
    property Align;
    property DrawingTool;
    property Paper;
    property PaperColor;
    property PaperWidth;
    property PaperHeight;
    property Zoom;
    property ShowGrid;
  end;

  TDrawBar=class(TCoolBar)
  private
    FButtons:array[1..17] of TSpeedButton;
    FDrawBox:TDrawBox;
    procedure FOnClick(Sender:TObject);
  public
    constructor create(AOwner:TComponent);override;
    destructor destroy;override;
  published
    property Align;
    property EdgeBorders;
    property DrawBox:TDrawBox read FDrawBox write FDrawBox;
  end;

  procedure Swap(var a,b:integer);overload;
  procedure Swap(var a,b:real);overload;
  procedure NormalizeRect(var r:TRect);overload;
  procedure NormalizeRect(var r:TRealRect);overload;
  function RealToInt(x:Real):integer;overload;
  function RealToInt(p:TRealPoint):TPoint;overload;
  function RealToInt(r:TRealRect):TRect;overload;

procedure Register;

implementation

{$R *.RES}

uses RectangleProperty,PolyLineProperty,PaperProperty;

const
  Version='Draw 1.0';


procedure Register;
begin
  RegisterComponents('Samples', [TDrawBox,TDrawBar]);
end;

function RealPoint(x,y:real):TRealPoint;
begin
  result.x:=x;
  result.y:=y;
end;

function RealRect(left,top,right,bottom:real):TRealRect;
begin
  result.left:=left;
  result.top:=top;
  result.right:=right;
  result.bottom:=bottom;
end;

procedure Swap(var a,b:integer);
var
  c:integer;
begin
  c:=a; a:=b; b:=c;
end;

procedure Swap(var a,b:real);
var
  c:real;
begin
  c:=a; a:=b; b:=c;
end;

procedure NormalizeRect(var r:TRect);
begin
  if r.left>r.Right then
    Swap(r.left,r.Right);

  if r.top>r.bottom then
    Swap(r.top,r.bottom);
end;

procedure NormalizeRect(var r:TRealRect);
begin
  if r.left>r.Right then
    Swap(r.left,r.Right);

  if r.top>r.bottom then
    Swap(r.top,r.bottom);
end;

function RealToInt(x:Real):integer;
begin
  result:=Round(x);
end;

function RealToInt(p:TRealPoint):TPoint;
begin
  result.x:=round(p.x);
  result.y:=round(p.y);
end;

function RealToInt(r:TRealRect):TRect;
begin
  result.left:=round(r.left);
  result.top:=round(r.top);
  result.right:=round(r.right);
  result.bottom:=round(r.bottom);
end;

function PtCode(const P: TPoint; const R: TRealRect): Integer;
begin
  Result := 0;
  if P.X < R.Left then Result := Result or 1;
  if P.Y < R.Top then Result := Result or 2;
  if P.X > R.Right then Result := Result or 4;
  if P.Y > R.Bottom then Result := Result or 8;
end;

function RectOnLine(const R: TRealRect;P:array of TRealPoint): Boolean;
label Start;
var
  p1,p2:TPoint;
  D1,D2: Integer;
begin
  p1:=RealToInt(p[0]);
  p2:=RealToInt(p[1]);

  D2 := PtCode(P2,R);
  Start: D1 := PtCode(P1,R);
  Result := D1 and D2 = 0;
  if not Result then Exit;
  Result := (D1=0) or (D2=0) or (D1 or D2 = 5) or (D1 or D2 = 10);
  if Result then Exit;
  if D1 and 1 <> 0 then begin
    P1.Y := P1.Y + MulDiv(P2.Y-P1.Y,RealToInt(R.Left-P1.X),P2.X-P1.X);
    P1.X := RealToInt(R.Left); goto Start;
  end;
  if D1 and 2 <> 0 then begin
    P1.X := P1.X + MulDiv(P2.X-P1.X,RealToInt(R.Top-P1.Y),P2.Y-P1.Y);
    P1.Y := RealToInt(R.Top); goto Start;
  end;
  if D1 and 4 <> 0 then begin
    P1.Y := P1.Y + MulDiv(P2.Y-P1.Y,RealToInt(R.Right-P1.X),P2.X-P1.X);
    P1.X := RealToInt(R.Right); goto Start;
  end;
  if D1 and 8 <> 0 then begin
    P1.X := P1.X + MulDiv(P2.X-P1.X,RealToInt(R.Bottom-P1.Y),P2.Y-P1.Y);
    P1.Y := RealToInt(R.Bottom); goto Start;
  end;
end;

{TDrawObj}
constructor TDrawObj.Create;
begin
  inherited Create;

  FPen:=TPen.Create;
  FPen.Color:=clBlack;
  FPen.Style:=psSolid;
  FPen.Width:=1;

  FBrush:=TBrush.Create;
  FBrush.Color:=clBlack;
  FBrush.Style:=bsClear;

  FFont:=TFont.Create;
  FFont.Name:='Arial';
  FFont.Size:=8;
  FFont.Color:=clBlack;
end;

destructor TDrawObj.Destroy;
begin
  FPen.Free;
  FBrush.Free;
  FFont.Free;

  inherited destroy;
end;

procedure TDrawObj.Draw(Canvas:TCanvas);
begin
end;

procedure TDrawObj.DrawHandle(Canvas:TCanvas);
var
  p:TRealPoint;
  i:integer;
begin
  with Canvas do begin
    for i:=1 to FHandleCount do begin
      p:=Handles(i);
      p:=View.DocToView(p,canvas);
      brush.Color:=clBlack;
      brush.Style:=bsSolid;
      Rectangle(round(p.x-3),round(p.y-3),round(p.x+3),round(p.y+3));
    end;
  end;
end;

function TDrawObj.Handles(AHandle:integer):TRealPoint;
begin
end;

function TDrawObj.GetCursor(p:TRealPoint;canvas:TCanvas):TCursor;
begin
end;

function TDrawObj.Bounds:TRealRect;
begin
end;

procedure TDrawObj.Move(dx,dy:Real);
var
  i:integer;
begin
  for i:=low(FPoints) to high(FPoints) do begin
    FPoints[i].x:=FPoints[i].x+dx;
    FPoints[i].y:=FPoints[i].y+dy;
  end;
end;

procedure TDrawObj.Normalize;
begin
end;

procedure TDrawObj.Alignment(AAlignment:TAlignment;pos:real);
begin
end;

procedure TDrawObj.ShowProperty;
begin
end;

procedure TDrawObj.HandleMove(dx,dy:Real);
begin
end;

function TDrawObj.HitTest(r:TRealRect;Canvas:TCanvas):integer;
begin
end;

{TRectangle}
constructor TRectangle.Create(points:array of TRealPoint);
var
  i:integer;
begin
  inherited Create;

  SetLength(FPoints,2);

  for i:=Low(FPoints) to High(FPoints) do begin
    FPoints[i]:=points[i];
  end;

  FHandleCount:=4;
  FShape:=stRectangle;
end;

destructor TRectangle.Destroy;
begin
  inherited destroy;
end;

procedure TRectangle.Draw(Canvas:TCanvas);
var
  i:integer;
  x,y,w,h,s:integer;
  points:array of TRealPoint;
begin
  SetLength(points,High(FPoints)+1);
  for i:=Low(FPoints) to High(FPoints) do begin
    points[i]:=View.DocToView(FPoints[i],Canvas);
  end;

  x:=Round(points[0].x);
  y:=Round(points[0].y);
  w:=Round(points[1].x-points[0].x);
  h:=Round(points[1].y-points[0].y);

  with Canvas do  begin
    Pen := FPen;
    Brush := FBrush;