janshapecontroller.pas

更好用的 shape 控件 delphi 3.0, 4.0, 5.0, 6.0, 7.0 適用

  ashape.SendToBack ;
  index:=FobjList.IndexOf (ashape);
  if index=-1 then exit;
  FobjList.Move (index,0);
end;

procedure TjanShapeController.BringToFrontClick(sender:TObject);
var Ashape:Tjanshape;
    index:integer;
begin
  Ashape:=Tjanshape(popupcomponent);
  ashape.BringToFront ;
  index:=FobjList.IndexOf (ashape);
  if index=-1 then exit;
  FobjList.Move (index,FobjList.count-1);
end;

procedure TjanShapeController.DeleteObjectClick(sender:TObject);
var
  i,index:integer;
begin
  if FSelObjList.count=0 then exit;
  for i:=0 to FSelObjList.count-1 do
  begin
    index:=FObjList.indexof(FSelObjList[i]);
    if index<>-1 then
    begin
      TjanShape(FObjList[index]).free;
      FObjList.Delete(index);
    end;
  end;
  FselObjList.clear;
  if assigned(onshapedeleted) then
    onshapedeleted(self);
end;


procedure TjanShapeController.SetonShapeDeleted(const Value: TNotifyEvent);
begin
  FonShapeDeleted := Value;
end;


procedure TjanShapeController.SetonMouseModeChanged(
  const Value: TonMouseModeChanged);
begin
  FonMouseModeChanged := Value;
end;


procedure TjanShapeController.SetonShapeSelected(
  const Value: TonShapeSelected);
begin
  FonShapeSelected := Value;
end;

procedure TjanShapeController.SelectingShape(Ashape: TjanShape);
var index,i:integer;
    gns:string;
    obj:TjanShape;
begin
  gns:=Ashape.GroupName ;
  index:=FSelObjList.IndexOf (AShape);
  if index<>-1 then
  begin
    if gns='' then
    begin
      AShape.Selected :=false;
      FSelObjList.Delete (index);
    end
    else
    begin
      for i:=FSelObjList.count-1 downto 0 do
      begin
        obj:=TjanShape(FSelObjList[i]);
        if obj.groupname=gns then
        begin
          obj.Selected :=false;
          FSelObjList.delete(i);
        end;
      end;
    end;
  end
  else
  begin
    if gns='' then
    begin
      Ashape.selected:=true;
      FSelObjList.Add(Ashape);
    end
    else begin
      for i:=0 to FObjList.count-1 do
      begin
        obj:=TjanShape(FobjList[i]);
        if obj.groupname=gns then
          if FSelObjList.indexof(obj)=-1 then
          begin
            obj.Selected :=true;
            FSelObjList.add(obj);
          end;
      end;
    end;
  end;


  if assigned(onshapeselected) then
    onshapeselected(self,Ashape);
end;

Function TjanShapeController.FindMenuCaption(ACaption:string):TmenuItem;
var i,c:integer;
    m:TMenuitem;

  function FindSubMenucaption(Amenuitem:TMenuItem;Acaption:string):TMenuItem;
  var ii,cc:integer;
      mm:TmenuItem;
  begin
    cc:=AMenuitem.count;
    if cc=0 then
    begin
      result:=nil;
      exit;
    end
    else
    for ii:=0 to cc-1 do
    begin
      mm:=AMenuItem.items[ii];
      if mm.caption=Acaption then
      begin
        result:=mm;
        exit;
      end
      else if mm.count>0 then
      begin
        result:=FindSubMenucaption(mm,Acaption); // recursion
        if result<>nil then exit;
      end;
    end;
    result:=nil;
  end;

begin
  c:=items.Count;
  if c=0 then
  begin
    result:=nil;
    exit;
  end
  else
  for i:=0 to c-1 do
  begin
    m:=items[i];
    if m.caption=Acaption then
    begin
      result:=m;
      exit;
    end
    else if m.count>0 then
    begin
      result:=FindSubMenucaption(m,Acaption);
      if result<>nil then exit;
    end;
  end;
  result:=nil;
end;

procedure TjanShapeController.SetUserShapes(const Value: TStringlist);
begin
  FUserShapes.assign(Value);
end;

{ TUserShapeProperty }

procedure TUserShapeProperty.Edit;
var
  ShapeForm: TShapeEditorForm;
  usr:TStringlist;
  obj:TjanShapeController;
begin
  try
  ShapeForm:=TShapeEditorForm.Create (application);
  obj:=getComponent(0) as TjanShapeController;
  ShapeForm.UserList.items.assign(obj.usershapes);
  if ShapeForm.showmodal=mrOK then
  begin
     obj.usershapes.Assign (ShapeForm.userlist.items);
  end;
  finally
    shapeForm.free;
  end;
end;

function TUserShapeProperty.Getattributes: TPropertyAttributes;
begin
  result:= inherited GetAttributes + [paDialog]-[pasubproperties];
end;

procedure TjanShapeController.PolyLineModeClick(sender: TObject);
var Ashape:Tjanshape;
begin
  Ashape:=Tjanshape(popupcomponent);
  TmenuItem(sender).checked:= not TmenuItem(sender).checked;
  ashape.PolyLineMode :=TmenuItem(sender).checked;
end;

procedure TjanShapeController.MovingShape(AShape: TjanShape;dx,dy:integer);
var i,index,x,y,w,h,dw,dh,x2,y2,yh,xw:integer;
    obj:TjanShape;

begin
  if FSelObjList.count<>0 then
  for i:=0 to FSelObjList.count-1 do
    if FSelObjList[i]<>Ashape then
    begin
      obj:=Tjanshape(FSelObjList[i]);
      obj.left:=obj.left+dx;
      obj.top:=obj.top+dy;
    end;
  x:=Ashape.left;
  y:=Ashape.top;
  h:=Ashape.height;
  w:=Ashape.Width;
  yh:=y+h-1;
  xw:=x+w-1;
  x2:=x+ (w div 2);
  y2:=y+ (h div 2);
  for i:=0 to FobjList.count-1 do
  begin
    obj:=TjanShape(FObjList[i]);
    if (obj.GroupName<>'') and(obj<>Ashape) then
    begin
      if AShape.ConnectorN=obj.GroupName then
      begin
        if y>obj.top+5 then
        begin
          obj.height:=y-obj.top;
        end;
      end
      else if AShape.ConnectorE=obj.GroupName then
      begin
        if xw<(obj.left+obj.width-5) then
        begin
          obj.width:=obj.left+obj.width-xw-1;
          obj.left:=xw+1;
        end;
      end
      else if AShape.ConnectorS=obj.GroupName then
      begin
        if yh<(obj.top+obj.height-5) then
        begin
          obj.height:=obj.top+obj.height-yh-1;
          obj.top:=yh+1;
        end;
      end
      else if AShape.ConnectorW=obj.GroupName then
      begin
        if  x>(obj.left+5) then
        begin
          obj.width:=x-obj.left;
        end;
      end;
    end;
  end;
end;


procedure TjanShapeController.InsertObj(AShape: TjanShape);
var index:integer;
begin
  index:=FObjList.IndexOf (Ashape);
  if index=-1 then
   if FobjList.count=0 then
     FObjList.Add (Ashape)
   else
     FObjList.Insert (0,Ashape);
end;


procedure TjanShapeController.AddObj(AShape: TjanShape);
var index:integer;
begin
  index:=FObjList.IndexOf (Ashape);
  if index=-1 then
     FObjList.Add (Ashape);
end;

procedure TjanShapeController.DeleteObj(AShape: TJanShape);
var i,index:integer;
    obj:TjanShape;
begin
  if FselObjList.count=0 then exit;
  for i:=0 to FSelObjList.count-1 do
  begin
    index:=FObjList.indexof(FSelObjList[i]);
    if index<>-1 then
    begin
      obj:=TjanShape(FObjList[index]);
      FobjList.Delete (index);
      obj.free;
    end;
  FSelObjList.Clear ;
  end;
end;

procedure TjanShapeController.DeSelectAll;
var i:integer;
begin
  if FSelObjList.count=0 then exit;
  for i:=0 to FSelObjList.count-1 do
    TjanShape(FSelObjList[i]).selected:=false;
  FSelObjList.clear;
end;

procedure TjanShapeController.SelectRect(R: Trect);
var i,oc:integer;
    obj:TjanShape;

  function objInRect(Aobj:TjanShape;RR:Trect):boolean;
  var xc,yc:integer;
  begin
    xc:=AObj.left+(Aobj.width div 2);
    yc:=Aobj.top+(AObj.height div 2);
    result:= (xc>=RR.left) and (yc>=RR.top) and
      (xc<=RR.right) and (yc<+RR.bottom);
  end;

begin
  oc:=FobjList.count;
  if oc=0 then exit;
  DeselectAll;
  for i:=0 to oc-1 do
  begin
    obj:=FobjList[i];
    if objInRect(obj,R) then
    begin
      obj.selected:=true;
      FSelObjList.Add (obj);
    end;
  end;
end;

procedure TjanShapeController.GroupNameClick(sender: TObject);
var
  i,index:integer;
  gns:string;
  obj:TjanShape;
begin
  if FSelObjList.count=0 then
  begin
    obj:=Tjanshape(popupcomponent);
    gns:=obj.GroupName ;
    if inputquery('ShapeController','Enter Groupname',gns) then
      obj.GroupName :=gns;
  end
  else
  begin
  gns:=TjanShape(FselObjList[0]).GroupName;
  if not inputquery('ShapeController','Enter Groupname',gns) then exit;
  for i:=0 to FSelObjList.count-1 do
     TjanShape(FSelObjList[i]).GroupName:=gns;
  end;
end;

procedure TjanShapeController.ConnectorEClick(sender: TObject);
var
  i,index:integer;
  gns:string;
  obj:TjanShape;
begin
    obj:=Tjanshape(popupcomponent);
    gns:=obj.ConnectorE;
    if inputquery('ShapeController','Enter ConnectorE',gns) then
      obj.ConnectorE :=gns;
end;

procedure TjanShapeController.ConnectorNClick(sender: TObject);
var
  i,index:integer;
  gns:string;
  obj:TjanShape;
begin
    obj:=Tjanshape(popupcomponent);
    gns:=obj.ConnectorN;
    if inputquery('ShapeController','Enter ConnectorN',gns) then
      obj.ConnectorN :=gns;
end;


procedure TjanShapeController.ClearAll;
var i:integer;
begin
  if FobjList.count=0 then exit;
  for i:=FobjList.count-1 downto 0 do
    TjanShape(FObjList[i]).free;
  FobjList.Clear ;
  FSelObjList.clear;
end;

procedure TjanShapeController.SaveAll(Afilename:string);
var
  fs:TFilestream;
  i:integer;
begin
  FS := TFileStream.Create(Afilename,fmCreate or fmShareDenyWrite);
  if FObjList.count=0 then exit;
  try
    for i := 0 to FObjList.count-1 do
      FS.WriteComponent(TjanShape(FobjList[i]));
  finally FS.Free;
  end;
end;

procedure TjanShapeController.ZOrderUp;
var i:integer;
begin
  if FobjList.count=0 then exit;
  for i:=FObjList.Count-1 downto 0 do
    TjanShape(FObjList[i]).bringtofront;
end;

procedure TjanShapeController.ZorderDown;
var i:integer;
begin
  if FobjList.count=0 then exit;
  for i:=0 to FObjList.Count-1 do
    TjanShape(FObjList[i]).bringtofront;
end;

procedure TjanShapeController.alLeftClick(sender: TObject);
var
  i,value:integer;
begin
  if FSelObjList.count<2 then exit;
  value:=TjanShape(FSelObjList[0]).left;
  for i:=1 to FSelObjList.count-1 do
     TjanShape(FSelObjList[i]).left:=value;
end;

procedure TjanShapeController.alRightClick(sender: TObject);
var
  i,value:integer;
  obj:TjanShape;
begin
  if FSelObjList.count<2 then exit;
  obj:=TjanShape(FSelObjList[0]);
  value:=obj.left+obj.width-1;
  for i:=1 to FSelObjList.count-1 do
  begin
     obj:=TjanShape(FSelObjList[i]);
     obj.left:=value-obj.width+1;
  end;
end;


procedure TjanShapeController.alTopClick(sender: TObject);
var
  i,value:integer;
begin
  if FSelObjList.count<2 then exit;
  value:=TjanShape(FSelObjList[0]).top;
  for i:=1 to FSelObjList.count-1 do
     TjanShape(FSelObjList[i]).top:=value;
end;

procedure TjanShapeController.alBottomClick(sender: TObject);
var
  i,value:integer;
  obj:TjanShape;
begin
  if FSelObjList.count<2 then exit;
  obj:=TjanShape(FSelObjList[0]);
  value:=obj.top+obj.height-1;
  for i:=1 to FSelObjList.count-1 do
  begin
     obj:=TjanShape(FSelObjList[i]);
     obj.top:=value-obj.height+1;
  end;
end;


procedure TjanShapeController.eqHeightClick(sender: TObject);
var
  i,value:integer;
begin
  if FSelObjList.count<2 then exit;
  value:=TjanShape(FSelObjList[0]).height;
  for i:=1 to FSelObjList.count-1 do
     TjanShape(FSelObjList[i]).height:=value;
end;

procedure TjanShapeController.eqWidthClick(sender: TObject);
var
  i,value:integer;
begin
  if FSelObjList.count<2 then exit;
  value:=TjanShape(FSelObjList[0]).width;
  for i:=1 to FSelObjList.count-1 do
     TjanShape(FSelObjList[i]).width:=value;
end;


procedure TjanShapeController.ConnectorSClick(sender: TObject);
var
  gns:string;
  obj:TjanShape;
begin
    obj:=Tjanshape(popupcomponent);
    gns:=obj.ConnectorS;
    if inputquery('ShapeController','Enter ConnectorS',gns) then
      obj.ConnectorS :=gns;
end;

procedure TjanShapeController.ConnectorWClick(sender: TObject);
var
  gns:string;
  obj:TjanShape;
begin
    obj:=Tjanshape(popupcomponent);
    gns:=obj.ConnectorW;
    if inputquery('ShapeController','Enter ConnectorW',gns) then
      obj.ConnectorW :=gns;
end;

end.