unthqjdraw.pas

这是个可以划出不同几何图形的程序

unit UntHQJDraw;
{***************************************************************}
{		 THQJDraw						}
{              }
{                  }
{                                                               }
{            }
{								}
{  E-Mail: [e-mail]				}
{                          04-2004	 by	Hu Qing Jiang		}
{								}
{***************************************************************}
interface

uses
  windows,SysUtils,Messages, Classes, Controls,Contnrs,Forms,dialogs,
  Graphics,UntShape;

type
   TDrawState=(dsNone,dsSelect,dsBeginDrag,dsOnSize);
  THQJDraw = class(TCustomControl)
  private
   ShpStr:TShapeProperty;
   ShapeList:TObjectList;
   CurrentIndex:integer; // 当前被选择的 图形 索引。
   CursorKind:TSizerType;
   LTPnt,RTPnt,RBPnt,LBPnt:TPoint;// one shape's four corner;
   //procedure AppendOne(Shp:TShapeElement);

   procedure DrawBGDBmp;
   //procedure DeleteOne(Shape:TBaseShape;Index:integer);
   procedure PaintAll;
   procedure RepaintOne(Index:integer);
   procedure ChangeCursor(Pnt:TPoint);
   procedure Drag_0(const x,y:integer);
   procedure Drag_1(const x,y:integer);
   procedure Drag_2(const x,y:integer);
   procedure Drag_3(const x,y:integer);
   procedure Drag_4(const x,y:integer);
   procedure Drag_5(const x,y:integer);
   procedure Drag_6(const x,y:integer);
   procedure Drag_7(const x,y:integer);
   procedure SelectedNone;
  private
    procedure WMSIZE(var msg:TMessage);message WM_SIZE;
    procedure WMERASEBKGND(var msg:TMessage);message WM_ERASEBKGND;
    procedure AddSLine(prpty:TShapeProperty);
  //  procedure AddMLine(prpty:TShapeProperty);
    procedure AddCylinder(prpty:TShapeProperty);
    procedure AddArrow(prpty:TShapeProperty);
    procedure AddRectangle(prpty:TShapeProperty);
    procedure AddDiamond(prpty:TShapeProperty);
    procedure AddEchelon(prpty:TShapeProperty);
    procedure AddEllipse(prpty:TShapeProperty);
    procedure AddTriangle(prpty:TShapeProperty);

  private
   FMemBmp:TBitmap;
   FGlyph:TBitmap;
   FLocked:Boolean;
   FDrawItem:TShapeElement;
   FState:TDrawState;
   StartPnt,EndPnt,ZeroPnt:TPoint;

   procedure SetDrawItem(val:TShapeElement);
   procedure SetState;
   procedure PrepairDraw(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
   procedure DrawItem( Shift: TShiftState; X, Y: Integer);
   procedure FinishDraw(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
   function HitTestAll(const Pnt:TPoint):integer;
   procedure DrawHotRect;
   procedure DrawHotLine;
   procedure DrawBoundRect(const x,y:integer);
  // procedure InvalidateShape;
   procedure MakeSizeRect;
   procedure ReSizeShape(Shape:TBaseShape;SizeKind:TSizerType;x,y:integer);
  protected
   procedure Paint;override;
    procedure Click;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;
  public
   constructor  Create(AOwner:TComponent);override;
   destructor  Destroy;override;
   function AddOne(shape:TShapeElement;SPrpty:TShapeProperty):Boolean;
   procedure DeleteCurrent;
  published
    property Color;
    property Align;
    property Item:TShapeElement read FDrawItem write SetDrawItem;
  end;

procedure Register;

implementation
   {$R draw.res}
procedure Register;
begin
  RegisterComponents('HQJVCL', [THQJDraw]);
end;

{ THQJDraw }



constructor THQJDraw.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetBounds(0,0,400,400);
  Color:=clBtnFace;
  CurrentIndex:=-1;
  CursorKind:=sTypeNone;
  FDrawItem:=seNone;
  FState:=dsNone;
  with ShpStr do
  begin
       FHeadPnt:=Point(10,10);
       FEndPnt:=Point(100,100);
       FLineWidth:=1;
       FLineColor:=clBlack;
       FColor:=clLime;
       FText:='';
       FDir:=sdUp;
       FFontSize:=10;
       FTransparent:=true;
  end;
  ShapeList:=TObjectList.Create;
  FMemBmp:=TBitmap.Create ;
  FGlyph:=TBitmap.Create ;
   FGlyph.LoadFromResourceName(hInstance,'BGD');



end;
destructor THQJDraw.Destroy;
begin
  ShapeList.Free;
  FMemBmp.free;
  FGlyph.Free;
  inherited destroy;
end;
procedure THQJDraw.DeleteCurrent;
begin
 if CurrentIndex>=0 then
 begin
 ShapeList.Delete(CurrentIndex);
 CurrentIndex:=-1;
 PaintAll;
 end;

end;
 {
procedure THQJDraw.DeleteOne(Shape: TBaseShape; Index: integer);
begin
   if ShapeList.Count>=Index+1 then
   ShapeList.Delete(Index);
end;
       }


procedure THQJDraw.Paint;
begin
 PaintAll;
 Canvas.Draw(0,0,FMemBmp) ;

end;

procedure THQJDraw.PaintAll;
var
i:integer;
begin
  DrawBGDBmp;
  if ShapeList.Count<0 then exit;
  for i:=0 to ShapeList.Count-1 do
  TBaseShape(ShapeList[i]).Paint(FMemBmp.Canvas.Handle);
  Canvas.Draw(0,0,FMemBmp);
end;

procedure THQJDraw.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  PrepairDraw(Button, Shift,X,Y);
end;

procedure THQJDraw.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  DrawItem(Shift,X,Y);
end;

procedure THQJDraw.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
   FinishDraw(Button, Shift,X,Y);
end;

procedure THQJDraw.Click;
begin
  inherited;

end;

function THQJDraw.HitTestAll(const Pnt: TPoint): integer;
var
i:integer;
begin
 result:=0;
 CurrentIndex:=-1;
 if ShapeList.Count<=0 then exit;
  for i:= (ShapeList.Count-1) downto 0 do
    if TBaseShape(ShapeList[i]).HitTest(Pnt) then
    begin
      Result:=i;
      CurrentIndex:=i;
      exit;
    end;
end;

procedure THQJDraw.RepaintOne(Index: integer);
begin
  if (index>=0)or(index<=ShapeList.Count-1) then
  begin
   FMemBmp.Width:=WIdth;
   FMemBmp.Height:=Height;
  TBaseShape(ShapeList[Index]).Paint(Canvas.Handle);// show it;
  TBaseShape(ShapeList[Index]).Paint(FMemBmp.Handle);//Draw it in offScreen Bmp;
  end;
end;
procedure THQJDraw.ChangeCursor(Pnt:TPoint);
var
kind:TSizerType;
begin
 if (CurrentIndex<=-1)or(FState=dsBeginDrag) then exit;
// GetCapture;
 kind:=TBaseShape(ShapeList[CurrentIndex]).ReSizeTest(Pnt);
 CursorKind:=Kind;
  case kind of
  sTypeFree     :begin
                   Self.Cursor:=crCross;
                   exit;
                 end;
  sTypeDrag     : begin
                   Self.Cursor:=crSizeAll;
                   exit;
                  end;
  sType0,sType4 : begin
                    Self.Cursor:=crSizeNWSE;
                    exit;
                  end;
  sType1,sType5 : begin
                    Self.Cursor:=crSizeNS;
                    exit;
                  end;
  sType2,sType6 : begin
                    Self.Cursor:=crSizeNESW;
                    exit;
                  end;
  sType3,sType7:  begin
                    Self.Cursor:=crSizeWE;
                    exit;
                  end;
 end;
 if (FState=dsBeginDrag) or (FState=dsOnSize) then exit;
 Self.cursor:=crDefault;
// ReleaseCapture;
end;

procedure THQJDraw.DrawHotRect;
var
pm:TPenMode;
ps:TPenStyle;
pc:TColor;
begin
 if (StartPnt.X=EndPnt.x)and(StartPnt.y=EndPnt.y) then exit;
 with Canvas do
 begin
   pm:=Pen.Mode;
   ps:=Pen.Style;
   pc:=Pen.color;
   pen.color:=clFuchsia;
   Pen.Mode:=pmNotXor;
   pen.Style:=psDashDotDot;
   MoveTo(StartPnt.x,StartPnt.y);
   LineTo(EndPnt.x,StartPnt.y);
   LineTo(EndPnt.x,EndPnt.y);
   LineTo(StartPnt.x,EndPnt.y);
   LineTo(StartPnt.x,StartPnt.y);
   Pen.Mode:=pm;
   pen.Style:=ps;
   pen.color:=pc;
 end;
end;
procedure THQJDraw.DrawBoundRect(const x,y:integer);
var
rc,NewRc:TRect;
xoff,yoff:integer;
Ps:TPenStyle;
pm:TPenMode;
begin
if ShapeList[CurrentIndex].ClassType=TBaseLine then
   begin
    DrawHotLine;
   exit;
   end;
  rc:=TBaseShape(ShapeList[CurrentIndex]).BoundRect;
  xoff:=ZeroPnt.x-rc.left;
  yoff:=ZeroPnt.Y-rc.top;
  NewRc.left:=x-xoff;
  NewRc.top:=y-yoff;
  NewRc.Right:=rc.Right-rc.left+x-xoff;
  NewRc.Bottom:=rc.Bottom-rc.Top+y-yoff;
  with Canvas do
  begin
   pm:=pen.mode;
   ps:=pen.Style;
   Pen.Mode:=pmNotXor;
   pen.Style:=psDot;
   MoveTo(Newrc.Left,Newrc.top);
   LineTo(NewRc.right,NewRc.top);
   LineTo(NewRc.right,NewRc.bottom);
   LineTo(NewRc.left,NewRc.bottom);
   LineTo(Newrc.Left,Newrc.top);;
   Pen.Mode:=pm;
   pen.Style:=ps;
  end;
end;

procedure THQJDraw.ReSizeShape(Shape: TBaseShape; SizeKind: TSizerType;x,y:integer);
begin
 case SizeKind of
  sType0: Drag_0(x,y);
  sType1: Drag_1(x,y);
  sType2: Drag_2(x,y);
  sType3: Drag_3(x,y);
  sType4: Drag_4(x,y);
  sType5: Drag_5(x,y);
  sType6: Drag_6(x,y);
  sType7: Drag_7(x,y);
  sTypeFree: begin
             if currentIndex<=-1 then exit;
              TBaseLine(ShapeList[CurrentIndex]).MoveCurrentPnt(x,y);
              exit;
             end;
 end;
  TBaseShape(ShapeList[CurrentIndex]).SetRect(LTPnt,RBPnt);