janshapecontroller.pas

delphi语言开发的矢量图形处理对象

unit janShapeController;



interface

uses
  Windows,
  TypInfo,
  Messages,
  SysUtils,
  Classes,
  Graphics,
  Controls,
  Forms,
  Dialogs,
  menus,
  DesignIntf,
  janshape,
  janShapeEditor,
  printers,
  DesignEditors;

type
  TonShapeSelected=procedure(sender:TObject;AShape:TjanShape) of object;
  TonMouseModeChanged= procedure (sender:TObject; AMouseMode:TShapeMouseMode) of object;
  TjanShapeController = class(TPopupMenu)
  private
    { Private declarations }
    FObjList:TList;
    FSelObjList:TList;
    FShape:TjanShape;
    FImageList:TImageList;
    FMenuCaptions:TStringlist;
    startimgshape:integer;
    startimggradient:integer;
    startimgUser:integer;
    FGradientColor: Tcolor;
    FBrushColor: Tcolor;
    FBackColor: TColor;
    FMouseMode: TShapeMouseMode;
    FMouseModeController: boolean;
    FMouseGrid: boolean;
    FMouseGridSize: integer;
    FonShapeDeleted: TNotifyEvent;
    FonMouseModeChanged: TonMouseModeChanged;
    FonShapeSelected: TonShapeSelected;
    FUserShapes: TStringlist;
    procedure CreateShapeImages;
    procedure initGradientStyleMenu;
    procedure initShapeStyleMenu;
    procedure initUserShapeStyleMenu;
    procedure initBrushStyleMenu;
    procedure initPenStyleMenu;
    procedure initBrushColorMenu;
    procedure initGradientmenu;
    procedure initGradientColorMenu;
    procedure initCaptionMenu;
    procedure initMouseMenu;
    procedure initOtherMenu;
    procedure SetBrushColor(const Value: Tcolor);
    procedure SetGradientColor(const Value: Tcolor);
    procedure SetBackColor(const Value: TColor);
    procedure ShapeStyleClick(sender:TObject);
    procedure GradientStyleClick(sender:TObject);
    procedure BrushStyleClick(sender:TObject);
    procedure PenStyleClick(sender:TObject);
    procedure BrushColorClick(sender:Tobject);
    procedure PenColorClick(sender:Tobject);
    procedure GradientColorClick(sender:Tobject);
    procedure GradientClick(sender:Tobject);
    procedure FontClick(sender:Tobject);
    procedure CaptionClick(sender:Tobject);
    procedure AngleClick(sender:Tobject);
    procedure PenSizeClick(sender:Tobject);
    procedure CenteredClick(sender:Tobject);
    procedure MouseModeClick(sender:TObject);
    procedure PolyLineModeClick(sender:TObject);
    procedure GroupNameClick(sender:TObject);
    procedure ActiveMouseClick(sender:Tobject);
    procedure popping(sender:TObject);
    function ScaleX(I: Integer): Integer;
    function ScaleY(I: Integer): Integer;
    procedure SetMouseMode(const Value: TShapeMouseMode);
    procedure SetMouseModeController(const Value: boolean);
    procedure SetMouseGrid(const Value: boolean);
    procedure SetMouseGridSize(const Value: integer);
    procedure BringToFrontClick(sender: TObject);
    procedure DeleteObjectClick(sender: TObject);
    procedure SendToBackClick(sender: TObject);
    procedure SetonShapeDeleted(const Value: TNotifyEvent);
    procedure SetonMouseModeChanged(const Value: TonMouseModeChanged);
    procedure SetonShapeSelected(const Value: TonShapeSelected);
    function FindMenuCaption(ACaption: string): TmenuItem;
    procedure SetUserShapes(const Value: TStringlist);
    procedure UserShapeStyleClick(sender: TObject);
    procedure ClearMenu;
    procedure initAlignMenu;
    procedure alBottomClick(sender: TObject);
    procedure alLeftClick(sender: TObject);
    procedure alRightClick(sender: TObject);
    procedure alTopClick(sender: TObject);
    procedure eqHeightClick(sender: TObject);
    procedure eqWidthClick(sender: TObject);
    procedure ConnectorNClick(sender: TObject);
    procedure ConnectorEClick(sender: TObject);
    procedure ConnectorSClick(sender: TObject);
    procedure ConnectorWClick(sender: TObject);
  protected
    { Protected declarations }
  public
    { Public declarations }
    {Assign a TjanShapeController as the popup component of TjanShape components and you can provide your users with full control over the shapes.}
    {}
    {Specially when you are using the shapes in a vector drawing program this is a real time saver.}
    constructor Create(AOwner:Tcomponent);override;
    {Creates an instance of TjanShapeController.}
    destructor Destroy;override;
    {Destroys an instance of TjanShapeController.}
    procedure CreateMenu;
    {Creates all the items of the popupmenu and all the images that are displayed with the menu items.}
    procedure ModifyshapeStyle(AShape:TjanShape;AShapeStyle:string);
    {Modifies the shape style using a string value.}
    {}
    {The value must be one of the valid shape styles.}
    procedure ModifyGradientStyle(AShape: TjanShape; AGradientStyle: string);
    {Modifies the gradient style using a string value.}
    procedure PrintShapes(var Alist:Tlist;scale:extended);
    {Prints all the TjanShape objects in Tlist to scale.}
    procedure SelectingShape(Ashape:TjanShape);
    {Select a TjanShape object. A selected shape is displayed with a square red mark in the center.}
    procedure SmoothResize(var Src, Dst: TBitmap);
    {Creates a smooth resized copy of Src bitmap in Dst bitmap.}
    {}
    {This is just a utility function you can use at will.}
    procedure MovingShape(AShape:TjanShape;dx,dy:integer);
    {You will normally not use this procedure directly.}
    {  }
    {TjanShape object that have a TjanShapeController as their popupcomponent will call this procedure when the user moves them. The ShapeController will move then all the shapes with the same groupname.}
    {}
    {The shapecontroller will also take care of positioning connector shapes if any.}
    procedure AddObj(AShape:TjanShape);
    {Add a TjanShape object to the object list.}
    procedure InsertObj(AShape: TjanShape);
    {Inserts a TjanShape object at the top of the object list.}
    procedure DeleteObj(AShape:TJanShape);
    {Deletes a TjanShape object from the list and frees the object.}
    procedure DeSelectAll;
    {Deselects all shapes in the Shapecontroller's shapes collection.}
    procedure ClearAll;
    {Clears all shapes from the shapecontroller's shapes collection and frees the shapes.}
    procedure SaveAll(Afilename:string);
    {Saves all TjanShape objects in the object list to a file with a .obd extension.}
    procedure SelectRect(R:Trect);
    {Selects all objects from the object list that are withitn the rectangle.}
    procedure ZOrderUp;
    {Changes the Zorder from the objects in the shapes collection from the last one up.}
    procedure ZorderDown;
    {Changes the Zorder from the objects in the shapes collection from the first one down.}
  published
    { Published declarations }
    property UserShapes:TStringlist read FUserShapes write SetUserShapes;
    {Hold all user defined shapes. A special property editor allows you to design new user shapes at design time.}
    {}
    {At run time when a TjanShape instance has a TjanShapeController as popupmenu the user can select any of these user shapes.}
    property BrushColor:Tcolor read FBrushColor write SetBrushColor;
    {Determines the BrushColor of the popup menu images.}
    property GradientColor:Tcolor read FGradientColor write SetGradientColor;
    {Determines the GradientColor of the popup menu images.}
    property BackColor:TColor read FBackColor write SetBackColor;
    {Determines the BackColor of the popup menu images.}
    property MouseMode:TShapeMouseMode read FMouseMode write SetMouseMode;
    {Determines the default mouse mode.}
    property MouseModeController:boolean read FMouseModeController write SetMouseModeController;
    {Determines if the shapecontroller will be used as a mousemode controller.}
    property MouseGrid:boolean read FMouseGrid write SetMouseGrid;
    {Determines if a grid will be used when sizing and moving shapes.}
    property MouseGridSize:integer read FMouseGridSize write SetMouseGridSize;
    {Determines the size of the grid in pixels.}
    property onShapeDeleted:TNotifyEvent read FonShapeDeleted write SetonShapeDeleted; //event
    {Occurs when the user deletes an object from the object list via the popup menu.}
    property onMouseModeChanged:TonMouseModeChanged read FonMouseModeChanged write SetonMouseModeChanged;//event
    {Occurs when the user changes the mousemode with the popup menu.}
    property onShapeSelected:TonShapeSelected read FonShapeSelected write SetonShapeSelected; //event
    {Occurs when the user selects an object from the list.}
  end;

  TUserShapeProperty=class (TClassproperty)
  public
    function Getattributes: TPropertyAttributes; override;
    procedure Edit;override;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('jans', [TjanShapeController]);
  RegisterPropertyEditor(TypeInfo(TStringList),TjanShapeController,'UserShapes',TUserShapeProperty);
end;

procedure TjanShapeController.ClearMenu;
var i,ic:integer;
    m:TMenuItem;

  procedure ClearSubmenu(mm:Tmenuitem);
  var ii,iic:integer;
      subm:TmenuItem;
  begin
     iic:=mm.Count ;
     if iic=0 then exit;
     for ii:=iic-1 downto 0 do
     begin
      subm:=mm.items[ii];
      ClearSubMenu(subm);
      mm.Delete (ii);
      subm.free;
     end;
  end;

begin
  ic:=items.Count ;
  if ic=0 then exit;
  for i:=ic-1 downto 0 do
  begin
    m:=items[i];
    ClearSubMenu(m);
    items.Delete (i);
    m.free;
  end;
end;

procedure TjanShapeController.CreateMenu;
begin
  FmenuCaptions.clear;
  FImageList.Clear ;
  ClearMenu;
  FMouseMode:=mmfixed;
  FMouseModeController:=false;
  CreateShapeImages;
  initShapeStyleMenu;
  initUserShapeStyleMenu;
  initGradientStyleMenu;
  initGradientmenu;
  initGradientColorMenu;
  initBrushColorMenu;
  initBrushStyleMenu;
  initPenStyleMenu;
  initCaptionMenu;
  initMouseMenu;
  initAlignmenu;
  initOthermenu;
end;

procedure TjanShapeController.CreateShapeImages;
var
  PropInfo: PPropInfo;
  ptd: PtypeData;
  i,j,imgcount,uc:integer;
  PropValue:integer;
  g:TjanShape;
  bm:tbitmap;
  R:Trect;
  cap:string;
begin
  if not assigned(images) then exit;
  g:=Fshape;
  g.Gradient :=false;
  R:=rect(0,0,16,16);
  PropInfo:=Getpropinfo(TjanShape.classinfo,'shape');
  ptd:=GetTypeData(PropInfo.proptype^);
  bm:=tbitmap.create;
  bm.height:=16;
  bm.width:=16;
  Images.Height :=16;
  Images.width:=16;
  images.AllocBy :=1;
  j:=0;
  startimgshape:=0;
// shapes
  for i:=ptd.MinValue to ptd.MaxValue do
  begin
    setordprop(g,propinfo,i);
//    g.Refresh;
    bm.canvas.brush.color:=FBackColor;
    bm.canvas.fillrect(R);
    FShape.PaintToCanvas(bm.canvas,0,0,1,1);
//    bm.Canvas.CopyRect (R,g.canvas,R);
    images.add(bm,nil);
    inc(j);
  end;
// gradients
  g.shape:=jstsquare;
  PropInfo:=Getpropinfo(TjanShape.classinfo,'FillDirection');
  ptd:=GetTypeData(PropInfo.proptype^);
  startimggradient:=j;
  g.Gradient :=true;
  for i:=ptd.MinValue to ptd.MaxValue do
  begin
    setordprop(g,propinfo,i);
//    g.Refresh;
//    bm.Canvas.CopyRect (R,g.canvas,R);
    bm.canvas.brush.color:=FBackcolor;
    bm.canvas.fillrect(R);
    Fshape.PainttoCanvas(bm.canvas,0,0,1,1);
    Images.add(bm,nil);
    inc(j);
  end;
// usershapes
  if assigned(FUserShapes) then
    if FUsershapes.count>0 then
    begin
      uc:=FUserShapes.count;
      g.shape:=jstuser;
      startimguser:=j;
      g.Gradient :=false;
      for i:=0 to uc-1 do
      begin
        g.UserVectorString :=FuserShapes[i];
        bm.canvas.brush.color:=FBackcolor;
        bm.canvas.fillrect(R);
        Fshape.PainttoCanvas(bm.canvas,0,0,1,1);
        Images.add(bm,nil);
        inc(j);
        end;
    end;
  bm.free;
end;

procedure TjanShapeController.initShapeStyleMenu;
var
 m,item:Tmenuitem;
 cap:string;
   PropInfo: PPropInfo;
   ptd: PtypeData;
   I,j:integer;
   PropValue:integer;
begin
 m:=Tmenuitem.Create (self);
 items.Add(m);
 m.caption:='Shape Style';
 PropInfo:=Getpropinfo(TjanShape.classinfo,'shape');
 ptd:=GetTypeData(PropInfo.proptype^);
 j:=0;
 for i:=ptd.MinValue to ptd.MaxValue do
 begin
   item:=tmenuitem.Create(self);
   item.caption:=getenumName(propinfo.proptype^,i);
   item.ImageIndex :=j;
   item.onclick:=shapestyleclick;
   FMenuCaptions.AddObject (item.caption,item);
   inc(j);
   m.add(item);
 end;
end;

procedure TjanShapeController.initUserShapeStyleMenu;
var
 m,item:Tmenuitem;
 cap:string;
 PropInfo: PPropInfo;
 ptd: PtypeData;
 I,j:integer;
 PropValue:integer;
 sc:integer;
begin
 if not assigned(FUserShapes) then exit;
 sc:=FUserShapes.count;
 if sc=0 then exit;
 m:=Tmenuitem.Create (self);
 items.Add(m);
 m.caption:='UserShape Style';
 j:=startimguser;
 for i:=0 to sc-1 do
 begin
   item:=tmenuitem.Create(self);
   item.caption:=FUserShapes.Names [i];
   item.ImageIndex :=j;
   item.onclick:=usershapestyleclick;
   FMenuCaptions.AddObject (item.caption,item);
   inc(j);
   m.add(item);
 end;
end;


procedure TjanShapeController.initGradientStyleMenu;
var
 m,item:Tmenuitem;
   PropInfo: PPropInfo;
   ptd: PtypeData;
   I,j,k:integer;
   PropValue:integer;
begin
 m:=Tmenuitem.Create (self);
 items.Add(m);
 m.caption:='GradientStyle';
 PropInfo:=Getpropinfo(TjanShape.classinfo,'FillDirection');
 ptd:=GetTypeData(PropInfo.proptype^);
 j:=0;
 k:=startimggradient;
 for i:=ptd.MinValue to ptd.MaxValue  do begin
 item:=tmenuitem.Create(m.owner);
 item.caption:=getenumName(propinfo.proptype^,i);
 item.ImageIndex :=k;
 FMenuCaptions.AddObject (item.caption,item);
 inc(k);
 item.onclick:=gradientstyleclick;
 inc(j);
 m.add(item);
 end;
end;

procedure TjanShapeController.ModifyshapeStyle(AShape:TjanShape;AShapeStyle:string);
begin
  setEnumprop(Ashape,'Shape',AshapeStyle);
end;

procedure TjanShapeController.ModifyGradientStyle(AShape:TjanShape;AGradientStyle:string);
begin
  setEnumprop(Ashape,'FillDirection',AGradientStyle);
  Ashape.gradient:=true;
end;


procedure TjanShapeController.SetBrushColor(const Value: Tcolor);
begin
  FBrushColor := Value;
  FShape.brush.Color :=value;
end;

procedure TjanShapeController.SetGradientColor(const Value: Tcolor);
begin
  FGradientColor := Value;
  FShape.GradientColor :=value;
end;

constructor TjanShapeController.Create(AOwner: Tcomponent);
begin
  inherited create(AOwner);
  FBrushColor:=clblue;
  FGradientColor:=clwhite;
  FBackColor:=clwhite;
  FMouseGrid:=false;
  FMouseGridSize:=10;
  FShape:=TjanShape.Create (self);
  Fshape.width:=16;
  FShape.height:=16;
  Fshape.GradientColor :=clwhite;
  Fshape.Brush.color:=clblue;
  FImageList:=TImageList.Create (self);
  FImageList.Width :=16;
  FImageList.Height :=16;
  FImageList.AllocBy:=1;
  FmenuCaptions:=TStringlist.create;
  FUserShapes:=TStringlist.create;
  FObjList:=Tlist.create;
  FSelObjList:=TList.create;
  Images:=FImageList;
  onpopup:=popping;

end;

procedure TjanShapeController.SetBackColor(const Value: TColor);
begin
  FBackColor := Value;
end;

destructor TjanShapeController.Destroy;
begin
  FShape.free;
  FImageList.free;
  FMenuCaptions.free;
  FuserShapes.free;
  FObjList.free;
  FSelObjList.free;
  inherited Destroy;
end;


procedure TjanShapeController.GradientStyleClick(sender: TObject);
var Ashape:Tjanshape;
    AGradientStyle:string;
begin
  Ashape:=Tjanshape(popupcomponent);
  AGradientStyle:=Tmenuitem(sender).caption;
  ModifyGradientStyle(Ashape,AGradientStyle);
end;

procedure TjanShapeController.ShapeStyleClick(sender: TObject);
var Ashape:Tjanshape;
    AshapeStyle:string;
begin
  Ashape:=Tjanshape(popupcomponent);
  AshapeStyle:=Tmenuitem(sender).caption;
  ModifyShapeStyle(Ashape,AshapeStyle);
end;

procedure TjanShapeController.UserShapeStyleClick(sender: TObject);
var Ashape:Tjanshape;
    AshapeStyle:string;
    index:integer;
begin
  Ashape:=Tjanshape(popupcomponent);
  AshapeStyle:=Tmenuitem(sender).caption;
  index:=FUserShapes.IndexOfName (AShapeStyle);
  if index=-1 then exit;
  Ashape.UserVectorString :=FUserShapes[index];
  Ashape.Shape:=jstUser;
end;


procedure TjanShapeController.BrushStyleClick(sender: TObject);
var Ashape:Tjanshape;
    AStyle:string;
begin
  Ashape:=Tjanshape(popupcomponent);
  AStyle:=Tmenuitem(sender).caption;
  setEnumprop(Ashape.brush,'Style',AStyle);
end;

procedure TjanShapeController.PenStyleClick(sender: TObject);
var Ashape:Tjanshape;
    AStyle:string;
begin