flexcontrols.pas

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

 else begin
  Invalidate;
  Result := InternalInsertPoints(Index, 3);
  if Result >= 0 then begin
   FPoints[Result+0] := Point;
   FPoints[Result+1] := CtrlPointA;
   FPoints[Result+2] := CtrlPointB;
   FPointTypes[Result+0] := ptNode;
   FPointTypes[Result+1] := ptControl;
   FPointTypes[Result+2] := ptControl;
   PointsChanged;
  end;
 end;
end;

procedure TFlexCurve.SetPointsEx(const APoints: TPointArray;
  const ATypes: TPointTypeArray);
begin
 if (Length(APoints) < 2) or (Length(APoints) <> Length(ATypes)) then exit;
 Invalidate;
 SetLength(FPoints, Length(APoints));
 SetLength(FPointTypes, Length(ATypes));
 if Length(FPoints) > 0 then begin
  Move(APoints[0], FPoints[0], Length(APoints)*SizeOf(APoints[0]));
  Move(ATypes[0], FPointTypes[0], Length(ATypes)*SizeOf(ATypes[0]));
 end;
 PointsChanged;
end;

procedure TFlexCurve.GetPointsEx(out APoints: TPointArray;
  out ATypes: TPointTypeArray);
begin
 SetLength(APoints, Length(FPoints));
 SetLength(ATypes, Length(FPointTypes));
 if Length(APoints) > 0 then begin
  Move(FPoints[0], APoints[0], Length(APoints)*SizeOf(APoints[0]));
  Move(FPointTypes[0], ATypes[0], Length(ATypes)*SizeOf(ATypes[0]));
 end;
end;

function TFlexCurve.EditPoints(Func: TPathEditFunc;
  const Selected: TSelectedArray; Params: PPathEditParams = Nil): boolean;
begin
 Result := EditPath(FPoints, FPointTypes, Selected, Func, Params);
 if Result then PointsChanged;
end;

function TFlexCurve.EditPointsCaps(
  const Selected: TSelectedArray): TPathEditFuncs;
begin
 Result := GetEditPathCaps(FPoints, FPointTypes, Selected);
end;

// TFlexText /////////////////////////////////////////////////////////////////

procedure TFlexText.ControlCreate;
begin
 inherited;
 FTextProp.Text := Name;
 FBrushProp.Color := clNone;
 FPenProp.Style := psClear;
 FAlwaysFilled := true;
 //FAutoSizeProp.Value := true;
end;

procedure TFlexText.CreateProperties;
var A: TAlignment;
    L: TTextLayout;
begin
 inherited;
 FAutoSizeProp := TBoolProp.Create(Props, 'AutoSize');
 FTextProp := TStrListProp.Create(Props, 'Text');
 FFontProp := TFontProp.Create(Props, 'Font');
 FWordWrapProp := TBoolProp.Create(Props, 'WordWrap');
 FGrayedProp := TBoolProp.Create(Props, 'Grayed');
 FAngleProp := TIntProp.Create(Props, 'Angle');
 FAlignmentProp := TEnumProp.Create(Props, 'Alignment');
 with FAlignmentProp do
 for A:=Low(A) to High(A) do
  case A of
   taLeftJustify  : AddItem('LeftJustify');
   taRightJustify : AddItem('RightJustify');
   taCenter       : AddItem('Center');
  end;
 FLayoutProp := TEnumProp.Create(Props, 'Layout');
 with FLayoutProp do
 for L:=Low(L) to High(L) do
  case L of
   tlTop    : AddItem('Top');
   tlCenter : AddItem('Center');
   tlBottom : AddItem('Bottom');
  end;
end;

class function TFlexText.CursorInCreate: TCursor;
begin
 Result := crCreateTextCursor;
end;

procedure TFlexText.ControlTranslate(const TranslateInfo: TTranslateInfo);
var Degree: integer;
begin
 Degree := (FAngleProp.Value + TranslateInfo.Rotate) mod 360;
 if Degree < 0 then Degree := 360 + Degree;
 if Degree <> 0 then FAutoSizeProp.Value := False;
 FAngleProp.Value := Degree;
 inherited;
end;

function TFlexText.CreateCurveControl: TFlexControl;
begin
 // Not supported in current version
 Result := Nil;
end;

procedure TFlexText.PropChanged(Sender: TObject; Prop: TCustomProp);
var Size: TSize;
begin
 inherited;
 if (Prop = HeightProp) and Owner.InDesign and
    (Owner.ToolMode in [ftmResizing, ftmCreating]) then begin
  if GetKeyState(VK_SHIFT) and $8000 {SHIFTED} <> 0 then
   // Change font size
   FFontProp.Height := -HeightProp.Value;
 end else
 if Prop = FAutoSizeProp then begin
  if FAutoSizeProp.Value then begin
   Size := TextSize;
   if (Size.cx = 0) and (Size.cy = 0) then exit;
   Width := Size.cx;
   Height := Size.cy;
   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 FAutoSizeProp.Value then begin
  Size := TextSize;
  if (Size.cx = 0) and (Size.cy = 0) then exit;
  if Size.cx < 1 then Size.cx := 1;
  if Size.cy < 1 then Size.cy := 1;
  if (Size.cx <> Width) or (Size.cy <> Height) then begin
   with WidthProp do Style := Style - [psReadOnly];
   with HeightProp do Style := Style - [psReadOnly];
   Width := Size.cx;
   Height := Size.cy;
   with WidthProp do Style := Style + [psReadOnly];
   with HeightProp do Style := Style + [psReadOnly];
  end;
 end;
end;

procedure TFlexText.PropStored(Sender: TObject; Prop: TCustomProp;
  var IsStored: boolean);
begin
 if Prop = FAutoSizeProp then
  IsStored := FAutoSizeProp.Value
 else
 if Prop = FTextProp then
  IsStored := FTextProp.LinesCount > 0
 else
 if Prop = FWordWrapProp then
  IsStored := FWordWrapProp.Value
 else
 if Prop = FGrayedProp then
  IsStored := FGrayedProp.Value
 else
 if Prop = FAlignmentProp then
  IsStored := FAlignmentProp.EnumIndex <> 0
 else
 if Prop = FLayoutProp then
  IsStored := FLayoutProp.EnumIndex <> 0
 else
 if Prop = FAngleProp then
  IsStored := FAngleProp.Value <> 0
 else
  inherited;
end;

procedure TFlexText.DoDrawText(Canvas: TCanvas; var Rect: TRect;
  Flags: Longint; const Text: string);
var ABC: TABC;
begin
 Flags := Flags or DT_NOPREFIX;
 if Grayed then begin
  OffsetRect(Rect, 1, 1);
  Canvas.Font.Color := clBtnHighlight;
  Windows.DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
  OffsetRect(Rect, -1, -1);
  Canvas.Font.Color := clBtnShadow;
  Windows.DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
  if Flags and DT_CALCRECT <> 0 then begin
   inc(Rect.Right);
   inc(Rect.Bottom);
  end;
 end else
  Windows.DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
 if Flags and DT_CALCRECT <> 0 then begin
  if Text <> '' then begin
   FillChar(ABC, SizeOf(ABC), 0);
   if GetCharABCWidths(Canvas.Handle,
        Cardinal(Text[Length(Text)]), Cardinal(Text[Length(Text)]), ABC) then
    inc(Rect.Right, abs(ABC.abcC));
  end;
 end;
end;

procedure TFlexText.DrawText(Canvas: TCanvas; var R: TRect; CalcOnly, Scaled: boolean);
const
  Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
  WordWraps: array[Boolean] of Word = (0, DT_WORDBREAK);
var
  CalcRect: TRect;
  DrawStyle: Longint;
  Offset, x, y: integer;
  ALayout: TTextLayout;
  s: string;
  PrevRgn, ClipRgn: HRGN;
  LogFont: TLogFont;
  angle: double;
  NeedRotate: boolean;
  TM: TTextMetric;

 procedure SetClipRgn;
 begin
  if FRoundnessProp.Value = 0
   then ClipRgn := CreateRectRgnIndirect(R)
   else ClipRgn := CreateRoundRectRgn(
     R.Left, R.Top, R.Right+1, R.Bottom+1,
     FRoundnessProp.Value, FRoundnessProp.Value);
  PrevRgn := IntersectClipRgn(Canvas, ClipRgn);
 end;

begin
 PrevRgn := 0;
 ClipRgn := 0;
 with Canvas do
 try
  if Scaled
   then FFontProp.Setup(Canvas, Owner.Scale)
   else FFontProp.Setup(Canvas);
  NeedRotate := FAngleProp.Value <> 0;
  if NeedRotate then begin
   GetTextMetrics(Handle, TM);
   NeedRotate := TM.tmPitchAndFamily and TMPF_TRUETYPE <> 0;
  end;
  if not NeedRotate then begin
   Canvas.Brush.Style := bsClear;
   s := FTextProp.Text;
   { DoDrawText takes care of BiDi alignments }
   DrawStyle := DT_EXPANDTABS or
                WordWraps[FWordWrapProp.Value] or
                Alignments[Alignment];
   if CalcOnly then begin
    { Calculate only }
    DrawStyle := DrawStyle or DT_CALCRECT;
   end else begin
    { Calculate vertical layout }
    ALayout := Layout;
    if ALayout <> tlTop then begin
     CalcRect := R;
     DoDrawText(Canvas, CalcRect, DrawStyle or DT_CALCRECT, s);
     Offset := (R.Bottom - R.Top) - (CalcRect.Bottom - CalcRect.Top);
     DrawStyle := DrawStyle or DT_NOCLIP;
     SetClipRgn;
     if ALayout = tlBottom
      then OffsetRect(R, 0, Offset)
      else OffsetRect(R, 0, Offset div 2);
    end;
   end;
   DoDrawText(Canvas, R, DrawStyle, s);
  end else begin
   GetObject(Font.Handle, SizeOf(TLogFont), @LogFont);
   LogFont.lfEscapement := FAngleProp.Value * 10;
   Font.Handle := CreateFontIndirect(LogFont);
   SetClipRgn;
   angle := FAngleProp.Value;
   angle := (angle * Pi)/180;
   if (FAngleProp.Value >= 0) and (FAngleProp.Value <= 90) then begin
     x := r.Left;
     y := r.Top + Round((r.Bottom - r.Top) * sin(angle));
   end
   else if (FAngleProp.Value > 90) and (FAngleProp.Value <= 180) then begin
     x := r.Left + Round((r.Right - r.Left) * Abs(cos(angle)));
     y := r.Bottom;
   end
   else if (FAngleProp.Value > 180) and (FAngleProp.Value <= 270) then begin
     x := r.Right;
     y := r.Bottom + Round((r.Bottom - r.Top) * sin(angle));
   end
   else if (FAngleProp.Value > 270) and (FAngleProp.Value < 360) then begin
     x := r.Right - Round((r.Right - r.Left) * Abs(cos(angle)));
     y := r.Top;
   end
   else begin
     x := r.Left;
     y := r.Top;
   end;
   if CalcOnly
    then SetRectEmpty(R)
    else TextOut(x, y, FTextProp.Text);
  end;
  FLastTextRect := R;
 finally
  SelectClipRgn(Canvas.Handle, PrevRgn);
  DeleteObject(PrevRgn);
  DeleteObject(ClipRgn);
  Font.Color := clBlack;
 end;
end;
 {
function TFlexText.GetRefreshRect(RefreshX, RefreshY: integer): TRect;
var Size: TSize;
    Bmp: TBitmap;
begin
 if FAutoSizeProp.Value and (FAngleProp.Value = 0) then begin
  Bmp := TBitmap.Create;
  try
   SetRectEmpty(Result);
   DrawText(Bmp.Canvas, Result, True, True);
   Result.Right := ScalePixels(Result.Right);
   Result.Bottom := ScalePixels(Result.Bottom);
   OffsetRect(Result, RefreshX, RefreshY);
  finally
   Bmp.Free;
  end;
 end else
  Result := inherited GetRefreshRect(RefreshX, RefreshY);
end;
  }
procedure TFlexText.Paint(Canvas: TCanvas; var PaintRect: TRect);
var PenWidth: integer;
//    R: TRect;
begin
 inherited;
 PenWidth := UnScalePixels(FPenProp.ActiveWidth);
 InflateRect(PaintRect, -PenWidth, -PenWidth);
 dec(PaintRect.Right);
 dec(PaintRect.Bottom);
{R := GetRefreshRect(PaintRect.Left, PaintRect.Top);
 InflateRect(R, -PenWidth, -PenWidth);
 dec(R.Right);
 dec(R.Bottom); }
 DrawText(Canvas, PaintRect, False, True);
end;
{
function TFlexText.IsPointInside(PaintX, PaintY: integer): boolean;
var R: TRect;
begin
 Result := false;
 if FTextProp.LinesCount > 0 then begin
  if IsRectEmpty(FLastTextRect) then
   Result := true
  else begin
   Result := PtInRect(FLastTextRect, Point(PaintX, PaintY));
  end;
 end;
 if not Result then
  Result := inherited IsPointInside(PaintX, PaintY);
end;
}
function TFlexText.GetAlignment: TAlignment;
begin
 Result := TAlignment(FAlignmentProp.EnumIndex);
end;

function TFlexText.GetGrayed: boolean;
begin
 Result := FGrayedProp.Value;
end;

function TFlexText.GetLayout: TTextLayout;
begin
 Result := TTextLayout(FLayoutProp.EnumIndex);
end;

function TFlexText.GetWordWrap: boolean;
begin
 Result := FWordWrapProp.Value;
end;

procedure TFlexText.SetAlignment(const Value: TAlignment);
begin
  FAlignmentProp.EnumIndex := integer(Value);
end;

procedure TFlexText.SetGrayed(const Value: boolean);
begin
 FGrayedProp.Value := Value;
end;

procedure TFlexText.SetLayout(const Value: TTextLayout);
begin
 FLayoutProp.EnumIndex := integer(Value);
end;

procedure TFlexText.SetWordWrap(const Value: boolean);
begin
 FWordWrapProp.Value := Value;
end;

function TFlexText.GetTextSize: TSize;
var B: TBitmap;
    R: TRect;
begin
 B := TBitmap.Create;
 try
  SetRectEmpty(R);
  DrawText(B.Canvas, R, True, False);
  Result.cx := ScalePixels(R.Right);
  Result.cy := ScalePixels(R.Bottom);
 finally
  B.Free;
 end;
end;

///////////////////////////////////////////////////////////////////////////////

procedure RegisterControls;
begin
 RegisterFlexControl(TFlexBox);
 RegisterFlexControl(TFlexEllipse);
 RegisterFlexControl(TFlexPicture);
 RegisterFlexControl(TFlexText);
 RegisterFlexControl(TFlexCurve);
end;

initialization
 RegisterControls;

end.