flexcontrols.pas

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

/////////////////////////////////////////////////////////
//                                                     //
//    FlexGraphics library                             //
//    Copyright (c) 2002-2003, FlexGraphics software.  //
//                                                     //
//    Common controls classes                          //
//                                                     //
/////////////////////////////////////////////////////////

unit FlexControls;

{$I FlexDefs.inc}

interface

uses
  Windows, Classes, Graphics, Controls, StdCtrls,
  {$IFDEF FG_D6} Variants, {$ENDIF}
  FlexBase, FlexProps, FlexUtils, FlexPath;

type
  TFlexBox = class(TFlexControl)
  private
   FAlwaysFilled: boolean;
   FBrushProp: TBrushProp;
   FPenProp: TPenProp;
   FRoundnessProp: TIntProp;
  protected
   procedure CreateProperties; override;
   procedure ControlCreate; override;
   procedure ControlTranslate(const TranslateInfo: TTranslateInfo); override;
   function  CreateCurveControl: TFlexControl; override;
   function  CreateBoxRegion(Inflate: boolean = false): HRGN;
   procedure Paint(Canvas: TCanvas; var PaintRect: TRect); override;
   function  GetAnchorPoint: TPoint; override;
   procedure PropChanged(Sender: TObject; Prop: TCustomProp); override;
   procedure PropStored(Sender: TObject; Prop: TCustomProp;
     var IsStored: boolean); override;
  public
   class function CursorInCreate: TCursor; override;
   function  IsPointInside(PaintX, PaintY: integer): boolean; override;
   property  BrushProp: TBrushProp read FBrushProp;
   property  PenProp: TPenProp read FPenProp;
   property  RoundnessProp: TIntProp read FRoundnessProp;
  end;

  TFlexEllipse = class(TFlexControl)
  private
   FBrushProp: TBrushProp;
   FPenProp: TPenProp;
  protected
   function  CreateEllipseRegion(Inflate: boolean = False): HRGN;
   procedure CreateProperties; override;
   procedure ControlCreate; override;
   procedure ControlTranslate(const TranslateInfo: TTranslateInfo); override;
   function  CreateCurveControl: TFlexControl; override;
   procedure Paint(Canvas: TCanvas; var PaintRect: TRect); override;
   function  GetAnchorPoint: TPoint; override;
  public
   class function CursorInCreate: TCursor; override;
   function  IsPointInside(PaintX, PaintY: integer): boolean; override;
   property  BrushProp: TBrushProp read FBrushProp;
   property  PenProp: TPenProp read FPenProp;
  end;

  TFlexPicture = class(TFlexControl)
  private
   FAutoSizeProp: TBoolProp;
   FPictureProp: TPictureProp;
   FFrameIndexProp: TIntProp;
  protected
   procedure CreateProperties; override;
   procedure ControlCreate; override;
   procedure PropChanged(Sender: TObject; Prop: TCustomProp); override;
   procedure PropStored(Sender: TObject; Prop: TCustomProp;
     var IsStored: boolean); override;
   procedure Paint(Canvas: TCanvas; var PaintRect: TRect); override;
   function  GetRefreshRect(RefreshX, RefreshY: integer): TRect; override;
  public
   class function CursorInCreate: TCursor; override;
   function  IsPointInside(PaintX, PaintY: integer): boolean; override;
   property  PictureProp: TPictureProp read FPictureProp;
   property  FrameIndexProp: TIntProp read FFrameIndexProp;
   property  AutoSizeProp: TBoolProp read FAutoSizeProp;
  end;

  TFlexCurve = class(TFlexControl)
  private
   FBrushProp: TBrushProp;
   FPenProp: TPenProp;
   FPointsProp: TDataProp;
   FPathPointsProp: TDataProp; // Points in new format (coords + types)
   FIsSolidProp: TBoolProp;
   FChanging: boolean;
   FResizePoints: TPointArray;
   FCurveInfo: TPathInfo;
   FCurveInfoChanged: boolean;
  protected
   FPoints: TPointArray;
   FPointTypes: TPointTypeArray;
   FLastDocRect: TRect;
   procedure CreateProperties; override;
   procedure ControlCreate; override;
   procedure ControlDestroy; override;
   procedure ControlTranslate(const TranslateInfo: TTranslateInfo); override;
   function  GetPoint(Index: integer): TPoint; override;
   function  GetPointCount: integer; override;
   procedure SetPoint(Index: integer; const Value: TPoint); override;
   function  GetPointType(Index: integer): TPointType; override;
   procedure SetPointType(Index: integer; const Value: TPointType); override;
   procedure PointsChanged;
   function  GetAnchorPoint: TPoint; override;
   procedure StartResizing(const SelRect: TRect); override;
   procedure FinishResizing; override;
   procedure Paint(Canvas: TCanvas; var PaintRect: TRect); override;
   procedure PropBeforeChanged(Sender: TObject; Prop: TCustomProp); override;
   procedure PropChanged(Sender: TObject; Prop: TCustomProp); override;
   procedure PropStored(Sender: TObject; Prop: TCustomProp;
     var IsStored: boolean); override;
   procedure GetPointsData(Sender: TObject; var Value: Variant);
   procedure SetPointsData(Sender: TObject; var Value: Variant);
   procedure GetPathPointsData(Sender: TObject; var Value: Variant);
   procedure SetPathPointsData(Sender: TObject; var Value: Variant);
   function  GetIsPointsClosed: boolean; override;
   procedure SetIsPointsClosed(Value: boolean); override;
   procedure SetDocRect(Value: TRect); override;
   function  GetRefreshRect(RefreshX, RefreshY: integer): TRect; override;
   function  InternalInsertPoints(Index, Count: integer): integer;
   procedure InternalDeletePoints(Index, Count: integer);
   function  GetPointsInfo: PPathInfo; override;
  public
   function  EndUpdate: boolean; override;
   class function CursorInCreate: TCursor; override;
   function  IsPointInside(PaintX, PaintY: integer): boolean; override;
   function  InsertPoint(Index: integer; const Point: TPoint): integer; override;
   function  InsertNearestPoint(const Point: TPoint): integer; override;
   function  InsertCurvePoints(Index: integer; const Point,
     CtrlPointA, CtrlPointB: TPoint): integer; override;
   procedure DeletePoint(Index: integer); override;
   procedure SetPointsEx(const APoints: TPointArray;
     const ATypes: TPointTypeArray); override;
   procedure GetPointsEx(out APoints: TPointArray;
     out ATypes: TPointTypeArray); override;
   function  FlattenPoints(const Curvature: single): boolean; override;
   function  FindNearestPoint(const Point: TPoint;
     var Nearest: TNearestPoint): boolean; override;
   function  FindNearestPathSegment(const Point: TPoint; var FirstIndex,
     NextIndex: integer): boolean; override;
   function  EditPoints(Func: TPathEditFunc; const Selected: TSelectedArray;
     Params: PPathEditParams = Nil): boolean; override;
   function EditPointsCaps(const Selected: TSelectedArray): TPathEditFuncs;
     override;
   property  BrushProp: TBrushProp read FBrushProp;
   property  PenProp: TPenProp read FPenProp;
   property  IsSolidProp: TBoolProp read FIsSolidProp;
  end;

  TFlexText = class(TFlexBox)
  private
   FLastTextRect: TRect;
   FAutoSizeProp: TBoolProp;
   FTextProp: TStrListProp;
   FFontProp: TFontProp;
   FWordWrapProp: TBoolProp;
   FGrayedProp: TBoolProp;
   FAlignmentProp: TEnumProp;
   FLayoutProp: TEnumProp;
   FAngleProp: TIntProp;
   procedure DoDrawText(Canvas: TCanvas; var Rect: TRect; Flags: Longint;
     const Text: string);
   procedure DrawText(Canvas: TCanvas; var R: TRect; CalcOnly, Scaled: boolean);
   function  GetAlignment: TAlignment;
   function  GetLayout: TTextLayout;
   function  GetWordWrap: boolean;
   procedure SetAlignment(const Value: TAlignment);
   procedure SetLayout(const Value: TTextLayout);
   procedure SetWordWrap(const Value: boolean);
   function  GetGrayed: boolean;
   procedure SetGrayed(const Value: boolean);
   function  GetTextSize: TSize;
  protected
   procedure CreateProperties; override;
   procedure ControlCreate; override;
   procedure ControlTranslate(const TranslateInfo: TTranslateInfo); override;
   function  CreateCurveControl: TFlexControl; override;
   procedure Paint(Canvas: TCanvas; var PaintRect: TRect); override;
   procedure PropChanged(Sender: TObject; Prop: TCustomProp); override;
   procedure PropStored(Sender: TObject; Prop: TCustomProp;
     var IsStored: boolean); override;
//   function  GetRefreshRect(RefreshX, RefreshY: integer): TRect; override;
   property  TextSize: TSize read GetTextSize;
  public
   class function CursorInCreate: TCursor; override;
   //function  IsPointInside(PaintX, PaintY: integer): boolean; override;
   property  AutoSizeProp: TBoolProp read FAutoSizeProp;
   property  TextProp: TStrListProp read FTextProp;
   property  FontProp: TFontProp read FFontProp;
   property  Grayed: boolean read GetGrayed write SetGrayed;
   property  WordWrap: boolean read GetWordWrap write SetWordWrap;
   property  Alignment: TAlignment read GetAlignment write SetAlignment;
   property  Layout: TTextLayout read GetLayout write SetLayout;
   property  AngleProp: TIntProp read FAngleProp;
  end;

implementation

const
  BezierCircleCoeff = 0.55228474983;

// TFlexBox //////////////////////////////////////////////////////////////////

procedure TFlexBox.ControlCreate;
begin
 Width := 1;
 Height := 1;
 FBrushProp.Color := clNone;
 FBrushProp.Style := bsSolid;
 inherited;
 Visible := True;
end;

procedure TFlexBox.CreateProperties;
begin
 inherited;
 FBrushProp := TBrushProp.Create(Props, 'Brush');
 FPenProp := TPenProp.Create(Props, 'Pen');
 FRoundnessProp := TIntProp.Create(Props, 'Roundness');
 FRoundnessProp.Style := FRoundnessProp.Style + [ psScalable ]; 
end;

procedure TFlexBox.ControlTranslate(const TranslateInfo: TTranslateInfo);
begin
 inherited;
 FBrushProp.Translate(TranslateInfo);
end;

function TFlexBox.CreateCurveControl: TFlexControl;
var Right, Bottom, W, H: integer;
    dx, dy: integer;
    RoundHalf: integer;
begin
 Result := TFlexCurve.Create(Owner, Parent, Layer);
 try
  Result.BeginUpdate;
  try
   W := Width;
   H := Height;
   Right := W - PixelScaleFactor;
   Bottom := H - PixelScaleFactor;
   // Copy properties
   FlexControlCopy(Self, Result);
   // Make points data
   with TFlexCurve(Result) do begin
    // Delete all points
    while PointCount > 0 do DeletePoint(0);
    if FRoundnessProp.Value = 0 then begin
     // Make simple rectangle (with 4 points and CloseFigure)
     AddPoint(Point(0, 0));
     AddPoint(Point(Right, 0));
     AddPoint(Point(Right, Bottom));
     AddPoint(Point(0, Bottom));
     EndFigure;
    end else begin
     // Make rounded rectangle
     dx := Round(FRoundnessProp.Value * (1 - BezierCircleCoeff) / 2);
     dy := dx;
     RoundHalf := FRoundnessProp.Value div 2;
     AddPoint(Point(RoundHalf, 0));
     AddCurvePoints(
       Point(Right-RoundHalf, 0),
       Point(Right-dx, 0),
       Point(Right, dy) );
     AddPoint(Point(Right, RoundHalf));
     AddCurvePoints(
       Point(Right, Bottom-RoundHalf),
       Point(Right, Bottom-dy),
       Point(Right-dx, Bottom) );
     AddPoint(Point(Right-RoundHalf, Bottom));
     AddCurvePoints(
       Point(RoundHalf, Bottom),
       Point(dx, Bottom),
       Point(0, Bottom-dy) );
     AddPoint(Point(0, Bottom-RoundHalf));
     AddCurvePoints(
       Point(0, RoundHalf),
       Point(0, dy),
       Point(dx, 0) );
     EndFigure;
    end;
   end;
  finally
   Result.EndUpdate;
  end;
 except
  Result.Free;
  raise;
 end;
end;

function TFlexBox.CreateBoxRegion(Inflate: boolean = false): HRGN;
var R: TRect;
    PenWidth: integer;
    Round: integer;
    Rgn: HRGN;
begin
 R := PaintRect;
 PenWidth := ScaleValue(FPenProp.ActiveWidth, Owner.Scale);
 Round := ScaleValue(FRoundnessProp.Value, Owner.Scale);
 if Inflate then begin
  if (PenWidth > 2) {or FBrushProp.IsClear }then PenWidth := 2;
  InflateRect(R, PenWidth, PenWidth);
 end;
 if not Assigned(FRoundnessProp) or (FRoundnessProp.Value = 0) then
  Result := CreateRectRgnIndirect(R)
 else
 if PenWidth < 2 then
  Result := CreateRoundRectRgn(
                     R.Left, R.Top, R.Right+1, R.Bottom+1, Round, Round)
                //   R.Left, R.Top, R.Right, R.Bottom, Round, Round)
 else
  Result := CreateRoundRectRgn(
                     R.Left+1, R.Top+1, R.Right, R.Bottom, Round, Round);
 if not FAlwaysFilled and Inflate and FBrushProp.IsClear then begin
  //PenWidth := FPenProp.ActiveWidth;
  InflateRect(R, -PenWidth, -PenWidth);
  PenWidth := ScaleValue(FPenProp.ActiveWidth, Owner.Scale);
 { if PenWidth < 1 then begin
   DeleteObject(Result);
   Result := 0;
  end else }
  if PenWidth < 3 then PenWidth := 3;
  InflateRect(R, -PenWidth, -PenWidth);
  if Round > 0
   then Rgn := CreateRoundRectRgn(R.Left, R.Top, R.Right+1, R.Bottom+1,
                 Round-PenWidth, Round-PenWidth)
   else Rgn := CreateRectRgn(R.Left, R.Top, R.Right+1, R.Bottom+1);
  CombineRgn(Result, Result, Rgn, RGN_XOR);
  DeleteObject(Rgn);
 end;
end;

class function TFlexBox.CursorInCreate: TCursor;
begin
 Result := crCreateRectCursor;
end;

function TFlexBox.GetAnchorPoint: TPoint;
var Round: integer;
begin
 with DocRect do begin
  if FRoundnessProp.Value > WidthProp.Value
   then Round := WidthProp.Value
   else Round := FRoundnessProp.Value;
  Result.X := Left + Round div 2;
  Result.Y := Top;
 end;
 Owner.TransformPoint(Result);
end;

function TFlexBox.IsPointInside(PaintX, PaintY: integer): boolean;
var Rgn: HRGN;
begin
 if (FRoundnessProp.Value = 0) and not FBrushProp.IsClear then
  Result := inherited IsPointInside(PaintX, PaintY)
 else begin
  Rgn := CreateBoxRegion(True);
  try
   Result := PtInRegion(Rgn, PaintX, PaintY);
  finally
   DeleteObject(Rgn);
  end
 end;
end;

procedure TFlexBox.PropChanged(Sender: TObject; Prop: TCustomProp);
begin
 inherited;
 if Prop = FRoundnessProp then begin
  DoNotify(fnAnchorPoints);
 end;
end;

procedure TFlexBox.PropStored(Sender: TObject; Prop: TCustomProp;
  var IsStored: boolean);
begin
 if Prop = FRoundnessProp then
  IsStored := FRoundnessProp.Value <> 0
 else
  inherited;
end;

procedure TFlexBox.Paint(Canvas: TCanvas; var PaintRect: TRect);
var PrevRgn, ClipRgn: HRGN;
    Round: integer;

 procedure CanvasSetup;
 begin
  FPenProp.Setup(Canvas, Owner.Scale);
  FBrushProp.Setup(Canvas, Owner.Scale);
 end;

begin
 with Canvas do begin
  CanvasSetup;
  if FBrushProp.IsPaintAlternate then begin
   PrevRgn := 0;
   ClipRgn := CreateBoxRegion;
   try
    PrevRgn := IntersectClipRgn(Canvas, ClipRgn);
    FBrushProp.PaintAlternate(Canvas, PaintRect, Owner.PaintRect);
   finally
    SelectClipRgn(Canvas.Handle, PrevRgn);
    DeleteObject(ClipRgn);
    DeleteObject(PrevRgn);
   end;
   CanvasSetup;
  end;
  if FPenProp.ActiveWidth = 0 then begin
   inc(PaintRect.Right);
   inc(PaintRect.Bottom);
  end;
  if FRoundnessProp.Value = 0 then
   with PaintRect do Rectangle(Left, Top, Right, Bottom)
  else begin
   Round := ScaleValue(FRoundnessProp.Value, Owner.Scale);
   RoundRect(PaintRect.Left, PaintRect.Top, PaintRect.Right, PaintRect.Bottom,
         Round, Round);
  end;
 end;
end;

// TFlexEllipse //////////////////////////////////////////////////////////////

procedure TFlexEllipse.ControlCreate;
begin
 Width := 1;
 Height := 1;