flexcontrols.pas

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

 FBrushProp.Color := clNone;
 FBrushProp.Style := bsSolid;
 inherited;
 Visible := True;
end;

procedure TFlexEllipse.CreateProperties;
begin
 inherited;
 FBrushProp := TBrushProp.Create(Props, 'Brush');
 FPenProp := TPenProp.Create(Props, 'Pen');
end;

class function TFlexEllipse.CursorInCreate: TCursor;
begin
 Result := crCreateEllipseCursor;
end;

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

function TFlexEllipse.CreateCurveControl: TFlexControl;
var Right, Bottom, W, H: integer;
    dx, dy: integer;
    XHalf, YHalf: 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);
    // Make ellipse
    dx := Round(W * (1 - BezierCircleCoeff) / 2);
    dy := Round(H * (1 - BezierCircleCoeff) / 2);
    XHalf := W div 2;
    YHalf := H div 2;
    AddCurvePoints(
      Point(XHalf, 0),
      Point(Right-dx, 0),
      Point(Right, dy) );
    AddCurvePoints(
      Point(Right, YHalf),
      Point(Right, Bottom-dy),
      Point(Right-dx, Bottom) );
    AddCurvePoints(
      Point(XHalf, Bottom),
      Point(dx, Bottom),
      Point(0, Bottom-dy) );
    AddCurvePoints(
      Point(0, YHalf),
      Point(0, dy),
      Point(dx, 0) );
    EndFigure;
   end;
  finally
   Result.EndUpdate;
  end;
 except
  Result.Free;
  raise;
 end;
end;

function TFlexEllipse.CreateEllipseRegion(Inflate: boolean = False): HRGN;
var PenWidth: integer;
    R: TRect;
    Rgn: HRGN;
begin
 R := PaintRect;
 //PenWidth := UnScalePixels(FPenProp.ActiveWidth);
 PenWidth := ScaleValue(FPenProp.ActiveWidth, Owner.Scale);
 if Inflate then begin
  if PenWidth > 2 then PenWidth := 2;
  InflateRect(R, PenWidth, PenWidth);
 end;
 if PenWidth < 2 then
  Result := CreateEllipticRgn(R.Left, R.Top, R.Right+1, R.Bottom+1)
 else
  Result := CreateEllipticRgn(R.Left+1, R.Top+1, R.Right, R.Bottom);
 if Inflate and FBrushProp.IsClear then begin
  PenWidth := ScaleValue(FPenProp.ActiveWidth, Owner.Scale);
  //PenWidth := UnScalePixels(FPenProp.ActiveWidth);
  if PenWidth < 1 then begin
   DeleteObject(Result);
   Result := 0;
  end else
  if PenWidth < 2 then PenWidth := 2;
  InflateRect(R, -PenWidth, -PenWidth);
  Rgn := CreateEllipticRgn(R.Left+2, R.Top+2, R.Right-1, R.Bottom-1);
  CombineRgn(Result, Result, Rgn, RGN_XOR);
  DeleteObject(Rgn);
 end;
end;

function TFlexEllipse.IsPointInside(PaintX, PaintY: integer): boolean;
var Rgn: HRGN;
//    R: TRect;
begin
 Rgn := CreateEllipseRegion(True);
 if Rgn <> 0 then
  try
   Result := PtInRegion(Rgn, PaintX, PaintY);
  finally
   DeleteObject(Rgn);
  end
 else
  Result := False;
end;

function TFlexEllipse.GetAnchorPoint: TPoint;
begin
 with DocRect do begin
  Result.X := Left + Width div 2;
  Result.Y := Top;
 end;
 Owner.TransformPoint(Result);
end;

procedure TFlexEllipse.Paint(Canvas: TCanvas; var PaintRect: TRect);
var PrevRgn, ClipRgn: HRGN;
    R: TRect;

 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 := CreateEllipseRegion;
   try
    PrevRgn := IntersectClipRgn(Canvas, ClipRgn);
    FBrushProp.PaintAlternate(Canvas, PaintRect, Owner.PaintRect);
   finally
    SelectClipRgn(Canvas.Handle, PrevRgn);
    DeleteObject(PrevRgn);
    DeleteObject(ClipRgn);
   end;
   CanvasSetup;   
  end;
  R := PaintRect;
  if FPenProp.ActiveWidth = 0 then begin
   inc(R.Right);
   inc(R.Bottom);
  end;
  with R do Ellipse(Left, Top, Right, Bottom)
 end;
end;

// TFlexPicture //////////////////////////////////////////////////////////////

procedure TFlexPicture.ControlCreate;
begin
 Width := 1;
 Height := 1;
 inherited;
 Visible := True;
end;

procedure TFlexPicture.CreateProperties;
begin
 inherited;
 FAutoSizeProp := TBoolProp.Create(Props, 'AutoSize');
 FPictureProp := TPictureProp.Create(Props, 'Picture');
 FFrameIndexProp := TIntProp.Create(Props, 'FrameIndex');
end;

class function TFlexPicture.CursorInCreate: TCursor;
begin
 Result := crCreatePicCursor;
end;

function TFlexPicture.GetRefreshRect(RefreshX, RefreshY: integer): TRect;
begin
 Result := inherited GetRefreshRect(RefreshX, RefreshY);
 if Assigned(FPictureProp) and not FPictureProp.IsLoaded then
  inc(Result.Right);
end;

function TFlexPicture.IsPointInside(PaintX, PaintY: integer): boolean;
begin
 if Owner.InDesign or FPictureProp.IsLoaded
  then Result := inherited IsPointInside(PaintX, PaintY)
  else Result := false;
end;

procedure TFlexPicture.Paint(Canvas: TCanvas; var PaintRect: TRect);
var DefBrush: TBrush;
    DefPen: TPen;
begin
 if FPictureProp.IsLoaded then begin
  FPictureProp.Draw(Canvas, PaintRect, FFrameIndexProp.Value);
 end else
 if not Owner.PaintForExport and Owner.InDesign then
 with Canvas do begin
  DefBrush := Nil;
  DefPen := Nil;
  try
   DefBrush := TBrush.Create;
   DefPen := TPen.Create;
   Brush.Assign(DefBrush);
   Pen.Assign(DefPen);
  finally
   DefBrush.Free;
   DefPen.Free;
  end;
  Brush.Style := bsClear;
  with PaintRect do Rectangle(Left, Top, Right, Bottom);
  if (RectWidth(PaintRect) > 1) and (RectHeight(PaintRect) > 1) then begin
   MoveTo(PaintRect.Left, PaintRect.Top);
   LineTo(PaintRect.Right-1, PaintRect.Bottom-1);
   MoveTo(PaintRect.Right-1, PaintRect.Top);
   LineTo(PaintRect.Left, PaintRect.Bottom-1);
  end;
 end;
end;

procedure TFlexPicture.PropChanged(Sender: TObject; Prop: TCustomProp);
var Size: TRect;
begin
 inherited;
 if Prop = FAutoSizeProp then begin
  if FAutoSizeProp.Value then begin
   Size := FPictureProp.CellSizeRect;
   Size.Right := ScalePixels(Size.Right);
   Size.Bottom := ScalePixels(Size.Bottom);
   if not IsRectEmpty(Size) then begin
    Width := Size.Right;
    Height := Size.Bottom;
   end;
   with WidthProp do Style := Style + [psReadOnly];
   with HeightProp do Style := Style + [psReadOnly];
  end else begin
   with WidthProp do Style := Style - [psReadOnly];
   with HeightProp do Style := Style - [psReadOnly];
  end;
 end else
 if (Prop = FPictureProp) and
    FAutoSizeProp.Value and FPictureProp.IsLoaded then begin
  Size := FPictureProp.CellSizeRect;
  Size.Right := ScalePixels(Size.Right);
  Size.Bottom := ScalePixels(Size.Bottom);
  with WidthProp do Style := Style - [psReadOnly];
  with HeightProp do Style := Style - [psReadOnly];
  Width := Size.Right;
  Height := Size.Bottom;
  with WidthProp do Style := Style + [psReadOnly];
  with HeightProp do Style := Style + [psReadOnly];
 end;
end;

procedure TFlexPicture.PropStored(Sender: TObject; Prop: TCustomProp;
  var IsStored: boolean);
begin
 if Prop = FAutoSizeProp then
  IsStored := FAutoSizeProp.Value
 else
 if Prop = FFrameIndexProp then
  IsStored := FFrameIndexProp.Value <> 1
 else
  inherited;
end;

// TFlexCurve /////////////////////////////////////////////////////////////

procedure TFlexCurve.ControlCreate;
begin
 FCurveInfoChanged := true;
 FBrushProp.Color := clNone;
 FBrushProp.Style := bsSolid;
 SetLength(FPoints, 2);
 FPoints[0] := Point(0, 0);
 FPoints[1] := Point(0, 0);
 SetLength(FPointTypes, 2);
 FPointTypes[0] := ptNode; //PT_MOVETO;
 FPointTypes[1] := ptEndNode; //PT_LINETO;
 inherited;
 Visible := True;
end;

procedure TFlexCurve.CreateProperties;
begin
 inherited;
 FBrushProp := TBrushProp.Create(Props, 'Brush');
 FPenProp := TPenProp.Create(Props, 'Pen');
 FIsSolidProp := TBoolProp.Create(Props, 'IsSolid');
 FPointsProp := TDataProp.Create(Props, 'Points');
 FPointsProp.OnGetPropData := GetPointsData;
 FPointsProp.OnSetPropData := SetPointsData;
 FPointsProp.Style :=  FPointsProp.Style - [ psVisible ];
 FPathPointsProp := TDataProp.Create(Props, 'PathPoints');
 FPathPointsProp.OnGetPropData := GetPathPointsData;
 FPathPointsProp.OnSetPropData := SetPathPointsData;
 FPathPointsProp.Style :=  FPathPointsProp.Style - [ psVisible ];
end;

procedure TFlexCurve.ControlDestroy;
begin
 SetLength(FPoints, 0);
 SetLength(FResizePoints, 0);
 inherited;
end;

function TFlexCurve.EndUpdate: boolean;
begin
 Result := inherited EndUpdate;
 if Result and not FChanging then PointsChanged;
end;

class function TFlexCurve.CursorInCreate: TCursor;
begin
 Result := crCreatePolyCursor;
end;

function TFlexCurve.GetAnchorPoint: TPoint;
var R: TRect;
begin
 R := DocRect;
 Result.X := R.Left;
 Result.Y := R.Top;
 if Length(FPoints) > 0 then begin
  inc(Result.X, FPoints[0].X);
  inc(Result.Y, FPoints[0].Y);
 end;
 Owner.TransformPoint(Result);
end;

function TFlexCurve.GetIsPointsClosed: boolean;
begin
 Result := FIsSolidProp.Value;
end;

procedure TFlexCurve.SetIsPointsClosed(Value: boolean);
begin
 FIsSolidProp.Value := Value;
end;

function TFlexCurve.GetPoint(Index: integer): TPoint;
begin
 Result := FPoints[Index];
end;

procedure TFlexCurve.SetPoint(Index: integer; const Value: TPoint);
begin
 if Assigned(Layer) and not Layer.Moveable then exit;
 FPoints[Index] := Value;
 PointsChanged;
end;

function TFlexCurve.GetPointType(Index: integer): TPointType;
begin
 Result := FPointTypes[Index];
end;

procedure TFlexCurve.SetPointType(Index: integer; const Value: TPointType);
begin
 if Assigned(Layer) and not Layer.Moveable then exit;
 FPointTypes[Index] := Value;
 PointsChanged;
end;

function TFlexCurve.GetPointCount: integer;
begin
 Result := Length(FPoints);
end;

function TFlexCurve.IsPointInside(PaintX, PaintY: integer): boolean;
var Pt: TPoint;
    PenWidth: integer;
    //APoints: TPointArray;
begin
 Pt := OwnerToClient(Point(PaintX, PaintY));
{ Pt.X := ScaleValue(Pt.X, Owner.Scale);
 Pt.Y := ScaleValue(Pt.Y, Owner.Scale);
 APoints := GetTransformPoints(0, 0, Owner.Scale); }
 PenWidth := (FPenProp.ActiveWidth +
   UnscaleValue(SelectionThreshold, Owner.Scale)) div 2;
 //if PenWidth < 2*PixelScaleFactor then PenWidth := 2*PixelScaleFactor;
 //PenWidth := ScaleValue(FPenProp.ActiveWidth div 2, Owner.Scale);
 //if PenWidth < 2 then PenWidth := 2;
 Result := PointOnPath(FPoints, FPointTypes, Pt, FPenProp.ActiveWidth > 0,
   not FBrushProp.IsClear, PenWidth, Nil, PointsInfo);
end;

procedure TFlexCurve.PropBeforeChanged(Sender: TObject; Prop: TCustomProp);
begin
 inherited;
 if FChanging or (Length(FPoints) = 0) then exit;
 if (Prop = WidthProp) or (Prop = HeightProp) then
  FLastDocRect := DocRect;
end;

procedure TFlexCurve.PropChanged(Sender: TObject; Prop: TCustomProp);
var R: TRect;
    Size: TPoint;
    ScaleX, ScaleY: Double;
    i: integer;
begin
 inherited;
 if FChanging or (Length(FPoints) = 0) then exit;
 if ((Prop = WidthProp) or (Prop = HeightProp)) and
    not Owner.IsLoading then begin
  R := DocRect;
  if EqualRect(R, FLastDocRect) then exit;
  Size.X := FLastDocRect.Right - FLastDocRect.Left;
  Size.Y := FLastDocRect.Bottom - FLastDocRect.Top;
  if Size.X <> 0
   then ScaleX := (R.Right - R.Left) / Size.X
   else ScaleX := 0;
  if Size.Y <> 0
   then ScaleY := (R.Bottom - R.Top) / Size.Y
   else ScaleY := 0;
  for i:=0 to High(FPoints) do begin
   FPoints[i].X := Round(FPoints[i].X * ScaleX);
   FPoints[i].Y := Round(FPoints[i].Y * ScaleY);
  end;
  PointsChanged;
 end else
 if Prop = IsSolidProp then with PointsInfo^ do
  if Length(Figures) > 0 then with Figures[High(Figures)] do begin