flexcontrols.pas

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

   Invalidate;
   if IsClosed
    then FPointTypes[LastNode] := ptEndNode
    else FPointTypes[LastNode] := ptEndNodeClose;
   PointsChanged;
  end;
end;

procedure TFlexCurve.PropStored(Sender: TObject; Prop: TCustomProp;
  var IsStored: boolean);
begin
 if Prop = FPointsProp then
  //IsStored := Length(FPoints) > 0
  IsStored := false // not supported 
 else
 if Prop = FPathPointsProp then
  IsStored := Length(FPoints) > 0
 else
 if Prop = FIsSolidProp then
  IsStored := FIsSolidProp.Value 
 else
  inherited;
end;

procedure TFlexCurve.GetPointsData(Sender: TObject; var Value: Variant);
var Size: integer;
    VArray: pointer;
begin
 Size := Length(FPoints) * SizeOf(FPoints[0]);
 if Size = 0 then begin
  VarClear(Value);
  exit;
 end;
 Value := VarArrayCreate([0, Size-1], varByte);
 VArray := VarArrayLock(Value);
 try
  Move(FPoints[0], VArray^, Size);
 finally
  VarArrayUnlock(Value);
 end;
end;

procedure TFlexCurve.SetPointsData(Sender: TObject; var Value: Variant);
var Size: integer;
    VArray: pointer;
    i, Count: integer;
begin
 if VarIsEmpty(Value) or VarIsNull(Value) or
    (VarType(Value) and varArray = 0) then exit;
 Size := VarArrayHighBound(Value, 1)+1;
 if Size mod SizeOf(FPoints[0]) <> 0 then exit;
 SetLength(FPoints, Size div SizeOf(FPoints[0]));
 VArray := VarArrayLock(Value);
 try
  Move(Varray^, FPoints[0], Size);
 finally
  VarArrayUnlock(Value);
 end;
 Count := Length(FPoints);
 SetLength(FPointTypes, Count);
 if Count > 0 then begin
  for i:=0 to Count-2 do FPointTypes[i] := ptNode;
  if IsPointsClosed
   then FPointTypes[Count-1] := ptEndNodeClose
   else FPointTypes[Count-1] := ptEndNode;
 end;
 PointsChanged;
end;

procedure TFlexCurve.GetPathPointsData(Sender: TObject; var Value: Variant);
var PointsSize, TypesSize, Size, Count: integer;
    VArray: pointer;
begin
 PointsSize := Length(FPoints)*(SizeOf(FPoints[0]));
 TypesSize := Length(FPointTypes)*(SizeOf(FPointTypes[0]));
 Size := PointsSize + TypesSize;
 if Size = 0 then begin
  VarClear(Value);
  exit;
 end;
 Value := VarArrayCreate([0, Size+SizeOf(Count) -1], varByte);
 VArray := VarArrayLock(Value);
 try
  // Save points count
  Count := Length(FPoints);
  Move(Count, VArray^, SizeOf(Count));
  VArray := pointer(PChar(VArray) + SizeOf(Count));
  // Save point coordinates
  Move(FPoints[0], VArray^, PointsSize);
  VArray := pointer(PChar(VArray) + PointsSize);
  // Save point types
  Move(FPointTypes[0], VArray^, TypesSize);
 finally
  VarArrayUnlock(Value);
 end;
end;

procedure TFlexCurve.SetPathPointsData(Sender: TObject; var Value: Variant);
var PointsSize, TypesSize, Size, Count: integer;
    VArray: pointer;
begin
 if VarIsEmpty(Value) or VarIsNull(Value) or
    (VarType(Value) and varArray = 0) then exit;
 Size := VarArrayHighBound(Value, 1)+1;
 if Size < SizeOf(Integer) then exit;
 VArray := VarArrayLock(Value);
 try
  // Read count
  Move(Varray^, Count, SizeOf(Count));
  VArray := pointer(PChar(VArray) + SizeOf(Count));
  // Calculate sizes and check data size 
  PointsSize := Count*SizeOf(FPoints[0]);
  TypesSize := Count*SizeOf(FPointTypes[0]);
  if Size <> SizeOf(Count) + PointsSize + TypesSize then exit;
  // Read point coordinates
  if PointsSize > 0 then begin
   SetLength(FPoints, Count);
   Move(VArray^, FPoints[0], PointsSize);
   VArray := pointer(PChar(VArray) + PointsSize);
  end else
   SetLength(FPoints, 0);
  // Read point types
  if TypesSize > 0 then begin
   SetLength(FPointTypes, Count);
   Move(VArray^, FPointTypes[0], TypesSize);
  end else
   SetLength(FPointTypes, 0);
 finally
  VarArrayUnlock(Value);
 end;
 PointsChanged;
end;

function TFlexCurve.GetPointsInfo: PPathInfo;
begin
 Result := @FCurveInfo;
 if not FCurveInfoChanged and (FCurveInfo.PointCount = Length(FPoints)) then exit;
 GetPathInfo(FPoints, FPointTypes, FCurveInfo);
 FCurveInfoChanged := false;
end;

procedure TFlexCurve.StartResizing;
begin
 inherited;
 SetLength(FResizePoints, Length(FPoints));
 Move(FPoints[0], FResizePoints[0], Length(FPoints)*SizeOf(FPoints[0]));
end;

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

procedure TFlexCurve.SetDocRect(Value: TRect);
var R: TRect;
    ScaleX, ScaleY: Double;
    Ofs: TPoint;
    i: integer;
begin
 if fsResizing in State then begin
  R := DocRect;
  with FResizingRect do begin
   if Right - Left > 0
    then ScaleX := (Value.Right - Value.Left) / (Right - Left)
    else ScaleX := 0;
   if Bottom - Top > 0
    then ScaleY := (Value.Bottom - Value.Top) / (Bottom - Top)
    else ScaleY := 0;
  end;
  Ofs.X := Value.Left - R.Left;
  Ofs.Y := Value.Top - R.Top;
  for i:=0 to High(FPoints) do begin
   FPoints[i].X := Round(FResizePoints[i].X * ScaleX) + Ofs.X;
   FPoints[i].Y := Round(FResizePoints[i].Y * ScaleY) + Ofs.Y;
  end;
  PointsChanged;
 end else
  inherited;
end;

procedure TFlexCurve.ControlTranslate(const TranslateInfo: TTranslateInfo);
var ASin, ACos: double;
    Ofs: TPoint;
    P: TPoint;
    i: integer;
begin
 with TranslateInfo do begin
  with DocRect do begin
   Ofs.X := Left - Center.X;
   Ofs.Y := Top  - Center.Y;
  end;
  ASin := sin(-Rotate * pi / 180);
  ACos := cos(-Rotate * pi / 180);
  for i:=0 to High(FPoints) do begin
   P.X := FPoints[i].X + Ofs.X;
   if Mirror then P.X := -P.X;
   P.Y := FPoints[i].Y + Ofs.Y;
   FPoints[i].X := Round((P.X * ACos) - (P.Y * ASin)) - Ofs.X;
   FPoints[i].Y := Round((P.X * ASin) + (P.Y * ACos)) - Ofs.Y;
  end;
  PointsChanged;
 end;
 FBrushProp.Translate(TranslateInfo);
end;

procedure TFlexCurve.PointsChanged;
var Bounds: TRect;
    i: integer;
begin
 FCurveInfoChanged := true;
 if (UpdateCounter > 0) or FChanging or Owner.IsLoading then exit;
 FChanging := true;
 try
  if Length(FPoints) = 0 then begin
   Width := 0;
   Height := 0;
   exit;
  end;
  Bounds.Left := FPoints[0].X;
  Bounds.Top := FPoints[0].Y;
  Bounds.Right := FPoints[0].X;
  Bounds.Bottom := FPoints[0].Y;
  if PointsInfo.IsCurve then begin
   // Calc curve bounds
   CalcPath(FPoints, FPointTypes, Bounds, PointsInfo);
  end else
  with Bounds do
   // Calc polyline bounds
   for i:=1 to High(FPoints) do begin
    if Left > FPoints[i].x then Left := FPoints[i].x else
    if Right < FPoints[i].x then Right := FPoints[i].x;
    if Top > FPoints[i].y then Top := FPoints[i].y else
    if Bottom < FPoints[i].y then Bottom := FPoints[i].y;
   end;
  // Offset curve points 
  if (Bounds.Left <> 0) or (Bounds.Top <> 0) then
   for i:=0 to High(FPoints) do begin
    dec(FPoints[i].X, Bounds.Left);
    dec(FPoints[i].Y, Bounds.Top);
   end;
  // Change curve control position and size
  BeginUpdate;
  try
   Left := Left + Bounds.Left;
   Top := Top + Bounds.Top;
   Width := Bounds.Right - Bounds.Left + PixelScaleFactor {+1};
   Height := Bounds.Bottom - Bounds.Top + PixelScaleFactor {+1};
  finally
   EndUpdate;
  end;
  // Define IsSolidProp value
  with PointsInfo^ do
   IsSolidProp.Value :=
     (Length(Figures) > 0) and Figures[High(Figures)].IsClosed;  
 finally
  FChanging := False;
 end;
 DoNotify(fnEditPoints);
end;

function TFlexCurve.FlattenPoints(const Curvature: single): boolean;
begin
 Result := FlattenPath(FPoints, FPointTypes, Curvature, PointsInfo);
 if Result then PointsChanged;
end;

function TFlexCurve.FindNearestPoint(const Point: TPoint;
  var Nearest: TNearestPoint): boolean;
begin
 PointOnPath(FPoints, FPointTypes, Point, True, False, 0, @Nearest,
   PointsInfo);
 Result := true;
end;

function TFlexCurve.FindNearestPathSegment(const Point: TPoint;
  var FirstIndex, NextIndex: integer): boolean;
begin
 Result := FlexPath.FindNearestPathSegment(FPoints, FPointTypes, Point,
  FirstIndex, NextIndex, PointsInfo);
end;

function TFlexCurve.GetRefreshRect(RefreshX, RefreshY: integer): TRect;
begin
 Result := inherited GetRefreshRect(RefreshX, RefreshY);
 if Assigned(FPenProp) and (FPenProp.ActiveWidth > 0) then
  InflateRect(Result,
    FPenProp.ActiveWidth+2*PixelScaleFactor,
    FPenProp.ActiveWidth+2*PixelScaleFactor );
end;

procedure TFlexCurve.Paint(Canvas: TCanvas; var PaintRect: TRect);
var ScrPoints: TPointArray;
    PrevRgn, ClipRgn: HRGN;
    DC: HDC;
    SavedDC: integer;
    Complete: boolean;
begin
 ScrPoints := GetTransformPoints(PaintRect.Left, PaintRect.Top, Owner.Scale);
 if Length(ScrPoints) = 0 then exit;
 FPenProp.Setup(Canvas, Owner.Scale);
 FBrushProp.Setup(Canvas, Owner.Scale);
 if PointsInfo.IsCurve or (Length(PointsInfo.Figures) > 1) then begin
  // Draw curve using CreatePath
  DC := Canvas.Handle;
  if not FBrushProp.IsClear then begin
   if not CreatePath(DC, ScrPoints, FPointTypes, True, False,
     Complete, Owner.UseOriginalBezier, PointsInfo) then exit;
   if FBrushProp.IsPaintAlternate then begin
    SavedDC := 0;
    if Complete then SavedDC := SaveDC(DC);
    PrevRgn := 0;
    try
     PrevRgn := IntersectClipPath(Canvas.Handle);
     FBrushProp.PaintAlternate(Canvas, PaintRect, Owner.PaintRect);
    finally
     SelectClipRgn(Canvas.Handle, PrevRgn);
     DeleteObject(PrevRgn);
    end;
    if Complete then
     // Restore canvas and created path
     RestoreDC(DC, SavedDC)
    else begin
     // Setup canvas and create path again (for closed and not closed figures)
     FPenProp.Setup(Canvas, Owner.Scale);
     FBrushProp.Setup(Canvas, Owner.Scale);
     DC := Canvas.Handle;
     if not CreatePath(DC, ScrPoints, FPointTypes, True, True,
       Complete, False, PointsInfo) then exit;
    end;
    // Stroke path
    StrokePath(DC);
   end else begin
    StrokeAndFillPath(DC);
    if not Complete and
      CreatePath(DC, ScrPoints, FPointTypes, False, True,
        Complete, Owner.UseOriginalBezier, PointsInfo) then
     StrokePath(DC);
   end;
  end else
  if CreatePath(DC, ScrPoints, FPointTypes, True, True,
    Complete, False, PointsInfo) then StrokePath(DC);
 end else begin
  // Draw curve as polyline
  if FBrushProp.IsPaintAlternate and PointsInfo.Figures[0].IsClosed then begin
   PrevRgn := 0;
   ClipRgn := CreatePolygonRgn(ScrPoints[0], Length(ScrPoints), ALTERNATE);
   try
    PrevRgn := IntersectClipRgn(Canvas, ClipRgn);
    FBrushProp.PaintAlternate(Canvas, PaintRect, Owner.PaintRect);
   finally
    SelectClipRgn(Canvas.Handle, PrevRgn);
    DeleteObject(PrevRgn);
    DeleteObject(ClipRgn);
   end;
   FPenProp.Setup(Canvas, Owner.Scale);
   FBrushProp.Setup(Canvas, Owner.Scale);
  end;
  if PointsInfo.Figures[0].IsClosed
   then Canvas.Polygon(ScrPoints)
   else Canvas.PolyLine(ScrPoints);
 end;
end;

function TFlexCurve.InternalInsertPoints(Index, Count: integer): integer;
begin
 if ChangePathCount(FPoints, FPointTypes, Index, +Count)
  then Result := Index
  else Result := -1;
end;

procedure TFlexCurve.InternalDeletePoints(Index, Count: integer);
begin
 ChangePathCount(FPoints, FPointTypes, Index, -Count);
end;

procedure TFlexCurve.DeletePoint(Index: integer);
var FigIndex, PrevNode, Count: integer;
    PrevCurve, NextCurve: boolean;
begin
 if FPointTypes[Index] = ptControl then exit;
 //if Length(FPoints) < 3 then exit;
 FigIndex := GetFigureIndex(PointsInfo^, Index);
 if FigIndex < 0 then exit;
 Count := Length(FPoints);
 with PointsInfo.Figures[FigIndex] do begin
  // Define previous node
  if Index = FirstNode then
   PrevNode := LastNode
  else
  if FPointTypes[Index-1] = ptControl
   then PrevNode := Index-3
   else PrevNode := Index-1;
  PrevCurve := (LastNode < Count-2) and (FPointTypes[PrevNode+1] = ptControl);
  NextCurve := (Index < Count-2) and (FPointTypes[Index+1] = ptControl);
  // Change types
  if Index = LastNode then
   if IsClosed
    then FPointTypes[PrevNode] := ptEndNodeClose
    else FPointTypes[PrevNode] := ptEndNode;
 end;
 Invalidate;
 if PrevCurve and NextCurve then FPoints[PrevNode+2] := FPoints[Index+2];
 if NextCurve
  then InternalDeletePoints(Index, 3)
  else InternalDeletePoints(Index, 1);
 PointsChanged;
end;

function TFlexCurve.InsertPoint(Index: integer;
  const Point: TPoint): integer;
begin
 if (Index < Length(FPoints)) and (FPointTypes[Index] = ptControl) then
  Result := -1
 else begin
  Invalidate;
  Result := InternalInsertPoints(Index, 1);
  if Result >= 0 then begin
   FPoints[Result] := Point;
   FPointTypes[Result] := ptNode;
   PointsChanged;
  end;
 end;
end;

function TFlexCurve.InsertNearestPoint(const Point: TPoint): integer;
begin
 Result := FlexPath.InsertNearestPoint(FPoints, FPointTypes,  
   Point, ScaleValue(SelectionThreshold, Owner.Scale), PointsInfo);
 if Result >= 0 then PointsChanged;
end;

function TFlexCurve.InsertCurvePoints(Index: integer; const Point,
  CtrlPointA, CtrlPointB: TPoint): integer;
begin
 if (Index < Length(FPoints)) and (FPointTypes[Index] = ptControl) then
  Result := -1