flexbase.pas

是一套创建矢量图形的VCL组件

   property  DocClipping: boolean read FDocClipping write SetDocClipping;
   property  SchemeBkStretch: boolean read FSchemeBkStretch
     write SetSchemeBkStretch;
   property  ShowDocFrame: boolean read FShowDocFrame write SetShowDocFrame
     default True;
   property  ShowGrid: boolean read GetShowGrid write SetShowGrid;
   property  ShowPixGrid: boolean read GetShowPixGrid write SetShowPixGrid;
   property  SnapToGrid: boolean read GetSnapToGrid write SetSnapToGrid;
   property  GridStyle: TFlexGridStyle read GetGridStyle write SetGridStyle;
   property  GridColor: TColor read GetGridColor write SetGridColor;
   property  GridPixColor: TColor read GetGridPixColor write SetGridPixColor;
   property  GridHorizSize: integer read GetGridHorizSize
     write SetGridHorizSize;
   property  GridVertSize: integer read GetGridVertSize write SetGridVertSize;
   property  ShowEditPointGuide: boolean read FShowEditPointGuide write
    SetShowEditPointGuide default true;
   property  OnPropBeforeChanged: TPropChangedEvent read FOnPropBeforeChanged
     write FOnPropBeforeChanged;
   property  OnPropChanged: TPropChangedEvent read FOnPropChanged
     write FOnPropChanged;
   property  OnNotify: TFlexNotifyEvent read FOnNotify write FOnNotify;
   property  OnPaintScheme: TFlexPaintEvent read FOnPaintScheme
     write FOnPaintScheme;
   property  OnPaintOver: TFlexPaintEvent read FOnPaintOver
     write FOnPaintOver;
   property  OnBeginSelectionUpdate: TNotifyEvent read FOnBeginSelectionUpdate
     write FOnBeginSelectionUpdate;
   property  OnEndSelectionUpdate: TNotifyEvent read FOnEndSelectionUpdate
     write FOnEndSelectionUpdate;
   property  OnProgress: TFlexProgressEvent read FOnProgress write FOnProgress;
   property  OnToolMode: TNotifyEvent read FOnToolMode write FOnToolMode;
   // inherited
   property  Align;
   property  Anchors;
   property  BiDiMode;
   property  BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle
     default bsSingle;
   property  Constraints;
   property  DockSite;
   property  DragCursor;
   property  DragKind;
   property  DragMode;
   property  Enabled;
   property  Color nodefault;
   property  Ctl3D;
   property  Font;
   property  ParentBiDiMode;
   property  ParentColor;
   property  ParentCtl3D;
   property  ParentFont;
   property  ParentShowHint;
   property  PopupMenu;
   property  ShowHint;
   property  TabOrder;
   property  TabStop;
   property  Visible;
   property  OnCanResize;
   property  OnClick;
   property  OnConstrainedResize;
   {$IFDEF FG_D5}
   property  OnContextPopup;
   {$ENDIF}
   property  OnDblClick;
   property  OnDockDrop;
   property  OnDockOver;
   property  OnDragDrop;
   property  OnDragOver;
   property  OnEndDock;
   property  OnEndDrag;
   property  OnEnter;
   property  OnExit;
   property  OnGetSiteInfo;
   property  OnMouseDown;
   property  OnMouseMove;
   property  OnMouseUp;
   property  OnMouseWheel;
   property  OnMouseWheelDown;
   property  OnMouseWheelUp;
   property  OnResize;
   property  OnStartDock;
   property  OnStartDrag;
   property  OnUnDock;
  end;

var
  RegisteredFlexControls: TFlexControlClasses;

procedure FirstControl(AControl: TFlexControl; var PassRec: TPassControlRec);
function  NextControl(var PassRec: TPassControlRec): TFlexControl;
procedure ClosePassRec(var PassRec: TPassControlRec);

procedure RegisterFlexControl(ControlClass: TFlexControlClass);

procedure InitPaintOrder(var PaintOrder: TPaintOrder);
procedure ClearPaintOrder(var PaintOrder: TPaintOrder);

function  TranslateRect(const R: TRect;
  const TranslateInfo: TTranslateInfo): TRect;
function  TranslateBounds(const R: TRect;
  const TranslateInfo: TTranslateInfo): TRect;

function  FlexControlCopy(Source, Destination: TFlexControl;
  Filer: TFlexFiler = Nil): boolean;

implementation

{$IFDEF STDFLEXCTRLS}
uses
  FlexControls; // for register flex controls only 
{$ENDIF}

procedure FirstControl(AControl: TFlexControl; var PassRec: TPassControlRec);
begin
 PassRec.Control := AControl;
 if Assigned(PassRec.Control) then begin
  SetLength(PassRec.Indexes, 1);
  PassRec.Indexes[0] := 0;
 end;
end;

function NextControl(var PassRec: TPassControlRec): TFlexControl;
var Idx: integer;
begin
 Result := Nil;
 with PassRec do
 try
  if Control.Count > 0 then begin
   Result := Control[0];
   SetLength(Indexes, Length(Indexes)+1);
   Indexes[High(Indexes)] := 0;
  end else
  repeat
   if Length(Indexes) = 1 then begin
    Result := Nil;
    break;
   end;
   Result := Control.Parent;
   if not Assigned(Result) then break;
   Idx := Indexes[High(Indexes)];
   inc(Idx);
   if Idx >= Result.Count then begin
    SetLength(Indexes, Length(Indexes)-1);
    Control := Result;
   end else begin
    Result := Result[Idx];
    Indexes[High(Indexes)] := Idx;
    break;
   end;
  until false;
 finally
  Control := Result;
  if not Assigned(Result) then SetLength(Indexes, 0);
 end;
end;

procedure ClosePassRec(var PassRec: TPassControlRec);
begin
 PassRec.Control := Nil;
 SetLength(PassRec.Indexes, 0);
end;

procedure InitPaintOrder(var PaintOrder: TPaintOrder);
begin
 PaintOrder.LayerRefs := Nil;
 PaintOrder.ControlRefs := Nil;
end;

procedure ClearPaintOrder(var PaintOrder: TPaintOrder);
begin
 SetLength(PaintOrder.LayerRefs, 0);
 SetLength(PaintOrder.ControlRefs, 0);
end;

function TranslateRect(const R: TRect;
  const TranslateInfo: TTranslateInfo): TRect;
var ASin, ACos: extended;
    P: TPoint;
begin
 Result := R;
 with TranslateInfo do begin
  OffsetRect(Result, -Center.X, -Center.Y);
  ASin := sin(-Rotate * pi / 180);
  ACos := cos(-Rotate * pi / 180);
  P := Result.TopLeft;
  if Mirror then P.X := -P.X;
  Result.Left := Round((P.X * ACos) - (P.Y * ASin));
  Result.Top  := Round((P.X * ASin) + (P.Y * ACos));
  P := Result.BottomRight;
  if Mirror then P.X := -P.X;
  Result.Right  := Round((P.X * ACos) - (P.Y * ASin));
  Result.Bottom := Round((P.X * ASin) + (P.Y * ACos));
  OffsetRect(Result, Center.X, Center.Y);
  Result := NormalizeRect(Result);
 end;
end;

function TranslateBounds(const R: TRect;
  const TranslateInfo: TTranslateInfo): TRect;
var Points: array[0..3] of TPoint;
    Point: TPoint;
    ASin, ACos: extended;
    i: integer;
begin
 Result := R;
 with TranslateInfo do begin
  OffsetRect(Result, -Center.X, -Center.Y);
  // Left-top
  Points[0].X := Result.Left;
  Points[0].Y := Result.Top;
  // Right-top
  Points[1].X := Result.Right;
  Points[1].Y := Result.Top;
  // Right-bottom
  Points[2].X := Result.Right;
  Points[2].Y := Result.Bottom;
  // Left-bottom
  Points[3].X := Result.Left;
  Points[3].Y := Result.Bottom;
  // Calculate sin/cos
  ASin := sin(-Rotate * pi / 180);
  ACos := cos(-Rotate * pi / 180);
  for i:=Low(Points) to High(Points) do begin
   if Mirror then Points[i].X := -Points[i].X;
   Point.X := Round((Points[i].X * ACos) - (Points[i].Y * ASin));
   Point.Y := Round((Points[i].X * ASin) + (Points[i].Y * ACos));
   if i=Low(Points) then begin
    Result.Left := Point.X; Result.Right  := Point.X;
    Result.Top  := Point.Y; Result.Bottom := Point.Y;
   end else begin
    if Point.X < Result.Left  then Result.Left  := Point.X else
    if Point.X > Result.Right then Result.Right := Point.X;
    if Point.Y < Result.Top    then Result.Top   := Point.Y else
    if Point.Y > Result.Bottom then Result.Bottom := Point.Y;
   end;
  end;
  OffsetRect(Result, Center.X, Center.Y);
 end;
end;

function FlexControlCopy(Source, Destination: TFlexControl;
  Filer: TFlexFiler = Nil): boolean;
var MS: TMemoryStream;
    InternalCreate: boolean;
begin
 MS := Nil;
 InternalCreate := not Assigned(Filer);
 try
  if InternalCreate then begin
   MS := TMemoryStream.Create;
   Filer := TFlexFiler.Create(MS);
  end;
  // Save source object to filer
  Source.SaveToFiler(Filer, '');
  Filer.Rewind;
  // Skip object struct head line
  Filer.LoadStr;
  // Load object from filer to destination
  Destination.LoadFromFiler(Filer);
  // Resolve refs
  Destination.Owner.PropRefList.ResolveAllRefs;
  // Success
  Result := true;
 finally
  if InternalCreate then begin
   Filer.Free;
   MS.Free;
  end;
 end;
end;

procedure RegisterFlexControl(ControlClass: TFlexControlClass);
var i: integer;
begin
 if Length(RegisteredFlexControls) > 0 then
  for i:=0 to High(RegisteredFlexControls) do
   if RegisteredFlexControls[i] = ControlClass then exit;
 SetLength(RegisteredFlexControls, Length(RegisteredFlexControls)+1);
 RegisteredFlexControls[High(RegisteredFlexControls)] := ControlClass;
end;

// TSchemeRefProp /////////////////////////////////////////////////////////////

constructor TSchemeRefProp.Create(AOwner: TPropList; const AName: string);
begin
 inherited;
 FIsEnum := true;
end;

function TSchemeRefProp.GetDisplayValue: string;
begin
 if Assigned(FValue)
  then Result := FValue.Name
  else Result := '';
end;

procedure TSchemeRefProp.SetValue(const Value: TFlexControl);
begin
 if (psReadOnly in Style) or (FValue = Value) then exit;
 DoBeforeChanged;
 FValue := Value;
 DoChanged;
end;

function TSchemeRefProp.GetNamesControl: TFlexControl;
begin
 Result := Nil;
 if Assigned(Owner.Owner) and (Owner.Owner is TFlexControl) then begin
  Result := TFlexControl(Owner.Owner).ParentScheme;
  if Assigned(Result) then Result := Result.Parent;
 end;
end;

procedure TSchemeRefProp.GetEnumList(List: TStrings);
var i: integer;
    Control: TFlexControl;
begin
 List.BeginUpdate;
 try
  List.Clear;
  List.Add('');
  Control := GetNamesControl;
  if Assigned(Control) then with Control do
   for i:=0 to Count-1 do List.AddObject(Controls[i].Name, Controls[i]);
 finally
  List.EndUpdate;
 end;
end;

function TSchemeRefProp.GetPropValue(const PropName: string): Variant;
begin
 if Assigned(FValue)
  then Result := FValue.Name
  else Result := '';
end;

procedure TSchemeRefProp.SetPropValue(const PropName: string; Value: Variant);
var AName: string;
    i: integer;
    Control: TFlexControl;
begin
 Control := GetNamesControl;
 if not Assigned(Control) then exit;
 try
  AName := VarAsType(Value, varString);
  if AName = '' then
   Self.Value := Nil
  else
  for i:=0 to Control.Count-1 do
   if CompareStr(Control[i].Name, AName) = 0 then begin
    Self.Value := Control[i];
    break;
   end;
 except
 end;
end;

// TFlexControl //////////////////////////////////////////////////////////////

constructor TFlexControl.Create(AOwner: TFlexPanel; AParent: TFlexControl;
  ALayer: TFlexLayer);
begin
 FState := [ fsCreating ];
 inherited Create;
 FOwner := AOwner;
 FControls := TList.Create;
 FProps := TPropList.Create(Self);
 FProps.OnPropChanged := PropChanged;
 FProps.OnPropBeforeChanged := PropBeforeChanged;
 FProps.OnPropStored := PropStored;
 FProps.OnPropReadOnly := PropReadOnly;
 CreateProperties;
 FAnchorEnabled := true;
 Parent := AParent;
 FLayer := ALayer;
 ControlCreate;
 Exclude(FState, fsCreating);
end;

destructor TFlexControl.Destroy;
begin
 if not (fsDestroying in FState) then exit;
 Clear;
 Parent := Nil;
 ControlDestroy;
 if Assigned(FOwner) then FOwner.FIdPool.Release(FIdProp.Value);
 FProps.Free;
 FControls.Free;
 inherited;
end;

procedure TFlexControl.BeforeDestruction;