lazarus-ccr/components/exctrls/source/exshape.pas

unit ExShape;

{$mode ObjFPC}{$H+}

interface

uses
  LCLVersion, Types, Graphics, Classes, SysUtils, ExtCtrls;

type
  {$IF LCL_FullVersion < 2020000}
  TVerticalAlignment = (taAlignTop, taAlignBottom, taVerticalCenter);
  {$ENDIF}

  TShapeText = class(TPersistent)
  private
    const
      cDefMargin = 8;
  private
    FShape: TShape;
    FHorAlignment: TAlignment;
    FHorMargin: Integer;
    FLines: TStrings;
    FVertAlignment: TVerticalAlignment;
    FVertMargin: Integer;
    function IsHorMarginStored: Boolean;
    function IsVertMarginStored: Boolean;
    procedure SetHorAlignment(const AValue: TAlignment);
    procedure SetHorMargin(const AValue: Integer);
    procedure SetLines(const AValue: TStrings);
    procedure SetVertAlignment(const AValue: TVerticalAlignment);
    procedure SetVertMargin(const AValue: Integer);
  protected
    procedure Changed(Sender: TObject); virtual;
  public
    constructor Create(AShape: TShape);
    destructor Destroy; override;
    procedure Assign(ASource: TPersistent); override;
  published
    property HorAlignment: TAlignment read FHorAlignment write SetHorAlignment default taCenter;
    property HorMargin: Integer read FHorMargin write SetHorMargin stored IsHorMarginStored;
    property Lines: TStrings read FLines write SetLines;
    property VertAlignment: TVerticalAlignment read FVertAlignment write SetVertAlignment default taVerticalCenter;
    property VertMargin: Integer read FVertMargin write SetVertMargin stored IsVertMarginStored;
  end;

  { TShapeEx}

  TShapeEx = class(TShape)
  private
    FHeader: TShapeText;
    FHeaderFont: TFont;
    FText: TShapeText;
    procedure SetHeader(const AValue: TShapeText);
    procedure SetHeaderFont(const AValue: TFont);
    procedure SetText(const AValue: TShapeText); reintroduce;
  protected
    function DefaultPlaceText(AText: TShapeText): TPoint;
    procedure HeaderFontChanged(Sender: TObject);
    function MeasureText(AText: TShapeText): TSize;
    function TextFlags(AText: TShapeText): Integer;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;
  published
    property Font;
    property Header: TShapeText read FHeader write SetHeader;
    property HeaderFont: TFont read FHeaderFont write SetHeaderFont;
    property Text: TShapeText read FText write SetText;
  end;


implementation

uses
  LCLIntf, LCLType;

{ TShapeText }

constructor TShapeText.Create(AShape: TShape);
begin
  inherited Create;
  FShape := AShape;
  FLines := TStringList.Create;
  FLines.SkipLastLineBreak := true;
  TStringList(FLines).OnChange := @Changed;
  FHorMargin := cDefMargin;
  FVertMargin := cDefMargin;
  FHorAlignment := taCenter;
  FVertAlignment := taVerticalCenter;
end;

destructor TShapeText.Destroy;
begin
  FLines.Free;
  inherited;
end;

procedure TShapeText.Assign(ASource: TPersistent);
begin
  if ASource is TShapeText then
  begin
    FLines.Assign(TShapeText(ASource).Lines);
    FHorAlignment := TShapeText(ASource).HorAlignment;
    FHorMargin := TShapeText(ASource).HorMargin;
    FVertAlignment := TShapeText(ASource).VertAlignment;
    FVertMargin := TShapeText(ASource).VertMargin;
  end else
    inherited;
end;

procedure TShapeText.Changed(Sender: TObject);
begin
  if FShape <> nil then
    FShape.Invalidate;
end;

function TShapeText.IsHorMarginStored: Boolean;
begin
  Result := FHorMargin <> cDefMargin;
end;

function TShapeText.IsVertMarginStored: Boolean;
begin
  Result := FVertMargin <> cDefMargin;
end;

procedure TShapeText.SetHorAlignment(const AValue: TAlignment);
begin
  if FHorAlignment <> AValue then
  begin
    FHorAlignment := AValue;
    Changed(Self);
  end;
end;

procedure TShapeText.SetHorMargin(const AValue: Integer);
begin
  if FHorMargin <> AValue then
  begin
    FHorMargin := AValue;
    Changed(Self);
  end;
end;

procedure TShapeText.SetLines(const AValue: TStrings);
begin
  if FLines.Text <> AValue.Text then
  begin
    FLines.Assign(AValue);
    FLines.SkipLastLineBreak := true;
    Changed(Self);
  end;
end;

procedure TShapeText.SetVertAlignment(const AValue: TVerticalAlignment);
begin
  if FVertAlignment <> AValue then
  begin
    FVertAlignment := AValue;
    Changed(Self);
  end;
end;

procedure TShapeText.SetVertMargin(const AValue: Integer);
begin
  if FVertMargin <> AValue then
  begin
    FVertMargin := AValue;
    Changed(Self);
  end;
end;


{ TShapeEx }

constructor TShapeEx.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  FHeader := TShapeText.Create(Self);
  FHeader.VertAlignment := taAlignTop;

  FHeaderFont := TFont.Create;
  FHeaderFont.Style := [fsBold];
  FHeaderFont.OnChange := @HeaderFontChanged;

  FText := TShapeText.Create(self);
end;

destructor TShapeEx.Destroy;
begin
  FText.Free;
  FHeader.Free;
  inherited;
end;

function TShapeEx.DefaultPlaceText(AText: TShapeText): TPoint;
var
  lSize: TSize;
begin
  if AText.Lines.Text = '' then
  begin
    Result := Point(MaxInt, MaxInt);
    exit;
  end;

  lSize := MeasureText(AText);
  case AText.HorAlignment of
    taLeftJustify: Result.X := AText.HorMargin;
    taCenter: Result.X := (ClientWidth - lSize.CX) div 2;
    taRightJustify: Result.X := ClientWidth - lSize.CX - AText.HorMargin;
  end;
  case AText.VertAlignment of
    taAlignTop: Result.Y := AText.VertMargin;
    taVerticalCenter: Result.Y := (ClientHeight - lSize.CY) div 2;
    taAlignBottom: Result.Y := ClientHeight - lSize.CY - AText.VertMargin;
  end;
end;

procedure TShapeEx.HeaderFontChanged(Sender: TObject);
begin
  Invalidate;
end;

function TShapeEx.MeasureText(AText: TShapeText): TSize;
var
  R: TRect;
  flags: Integer;
  s: String;
begin
  s := AText.Lines.Text;
  if s = '' then
  begin
    Result := Size(0, 0);
    exit;
  end;

  flags := DT_NOPREFIX or DT_CALCRECT or DT_WORDBREAK;
  if AText = FHeader then
    Canvas.Font.Assign(FHeaderFont)
  else
    Canvas.Font.Assign(Font);

  R := Rect(0, 0, ClientWidth, 0);
  R.Right := R.Right - 2 * AText.HorMargin;
  DrawText(Canvas.Handle, PChar(s), Length(s), R, flags);
  Result := Size(R.Width, R.Height);
end;

procedure TShapeEx.Paint;
type
  TTextItem = (tiHeader, tiText);
var
  P: array[TTextItem] of TPoint;
  s: array[TTextItem] of String;
  lSize: array[TTextItem] of TSize;
  flags: Integer;
  R: TRect;
  h, m: Integer;
begin
  // Draw the shape itself
  inherited Paint;

  s[tiHeader] := FHeader.Lines.Text;
  s[tiText] := FText.Lines.Text;

  // Get text size
  lSize[tiHeader] := MeasureText(FHeader);
  lSize[tiText] := MeasureText(FText);

  // Get default text positions
  P[tiHeader] := DefaultPlaceText(FHeader);
  P[tiText] := DefaultPlaceText(FText);

  // Fix special cases of positioning
  if (s[tiHeader] <> '') and (s[tiText] <> '') then
  begin
    // Texts colliding at top
    if (FHeader.VertAlignment = taAlignTop) and (FText.VertAlignment = taAlignTop) then
      P[tiText].Y := P[tiHeader].Y + lSize[tiHeader].CY + P[tiText].Y
    else
    // Texts colliding at center
    if (FHeader.VertAlignment = taVerticalCenter) and (FText.VertAlignment = taVerticalCenter) then
    begin
      // Average margin value
      m := (FHeader.VertMargin + FText.VertMargin) div 2;
      // Combined height of header and text, with average margin
      h := lSize[tiHeader].CY + lSize[tiText].CY + m;
      P[tiHeader].Y := (ClientHeight - h) div 2;
      P[tiText].Y := P[tiHeader].Y + lSize[tiHeader].CY + m;
    end else
    // Texts colliding at bottom
    if (FHeader.VertAlignment = taAlignBottom) and (FText.VertAlignment = taAlignBottom) then
      P[tiText].Y := P[tiHeader].Y - lSize[tiText].CY - FText.VertMargin
    else
    // Adjust centered Text when header is at top or bottom
    if (FText.VertAlignment = taVerticalCenter) then
    begin
      // Vertically available space without header
      h := ClientHeight - FHeader.VertMargin - lSize[tiHeader].CY;
      if (FHeader.VertAlignment = taAlignTop) then
        P[tiText].Y := P[tiHeader].Y + lSize[tiHeader].CY + (h - lSize[tiText].CY) div 2
      else
      if (FHeader.VertAlignment = taAlignBottom) then  // Keep header at bottom to become a footer
        P[tiText].Y := (h - lSize[tiText].CY) div 2;
    end;
  end;

  Canvas.Brush.Style := bsClear;
  flags := DT_NOPREFIX or DT_WORDBREAK;

  // Draw the header
  Canvas.Font.Assign(FHeaderFont);
  R.TopLeft := Point(0, 0);
  R.BottomRight := TPoint(lSize[tiHeader]);
  OffsetRect(R, P[tiHeader].X, P[tiHeader].Y);
  DrawText(Canvas.Handle, PChar(s[tiHeader]), Length(s[tiHeader]), R, flags or TextFlags(FHeader));

  // Draw the text
  Canvas.Font.Assign(Font);
  R.TopLeft := Point(0, 0);
  R.BottomRight := TPoint(lSize[tiText]);
  OffsetRect(R, P[tiText].X, P[tiText].Y);
  DrawText(Canvas.Handle, PChar(s[tiText]), Length(s[tiText]), R, flags or TextFlags(FText));
end;

procedure TShapeEx.SetHeader(const AValue: TShapeText);
begin
  FHeader.Assign(AValue);
  Invalidate;
end;

procedure TShapeEx.SetHeaderFont(const AValue: TFont);
begin
  FHeaderFont.Assign(AValue);
  Invalidate;
end;

procedure TShapeEx.SetText(const AValue: TShapeText);
begin
  FText.Assign(AValue);
  Invalidate;
end;

function TShapeEx.TextFlags(AText: TShapeText): Integer;
begin
  case AText.HorAlignment of
    taLeftJustify: Result := DT_LEFT;
    taCenter: Result := DT_CENTER;
    taRightJustify: Result := DT_RIGHT;
  end;
  case AText.VertAlignment of
    taAlignTop: Result := Result or DT_TOP;
    taVerticalCenter: Result := Result or DT_VCENTER;
    taAlignBottom: Result := Result or DT_BOTTOM;
  end;
end;

end.