ExCtrls: New component TShapeEx (text in shape)

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@8484 8e941d3f-bd1b-0410-a28a-d453659cc2b4

components/exctrls/examples/ShapeEx/demo.lpi

@@ -0,0 +1,86 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="12"/>
+    <PathDelim Value="\"/>
+    <General>
+      <Flags>
+        <CompatibilityMode Value="True"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <Title Value="demo"/>
+      <Scaled Value="True"/>
+      <ResourceType Value="res"/>
+      <UseXPManifest Value="True"/>
+      <XPManifest>
+        <DpiAware Value="True"/>
+      </XPManifest>
+      <Icon Value="0"/>
+    </General>
+    <BuildModes Count="1">
+      <Item1 Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+      <UseFileFilters Value="True"/>
+    </PublishOptions>
+    <RunParams>
+      <FormatVersion Value="2"/>
+    </RunParams>
+    <RequiredPackages Count="2">
+      <Item1>
+        <PackageName Value="ExCtrlsPkg"/>
+      </Item1>
+      <Item2>
+        <PackageName Value="LCL"/>
+      </Item2>
+    </RequiredPackages>
+    <Units Count="2">
+      <Unit0>
+        <Filename Value="demo.lpr"/>
+        <IsPartOfProject Value="True"/>
+      </Unit0>
+      <Unit1>
+        <Filename Value="main.pas"/>
+        <IsPartOfProject Value="True"/>
+        <ComponentName Value="MainForm"/>
+        <HasResources Value="True"/>
+        <ResourceBaseClass Value="Form"/>
+      </Unit1>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <PathDelim Value="\"/>
+    <Target>
+      <Filename Value="demo"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+    <Linking>
+      <Debugging>
+        <DebugInfoType Value="dsDwarf3"/>
+      </Debugging>
+      <Options>
+        <Win32>
+          <GraphicApplication Value="True"/>
+        </Win32>
+      </Options>
+    </Linking>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

components/exctrls/examples/ShapeEx/demo.lpr

@@ -0,0 +1,25 @@
+program demo;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}
+  cthreads,
+  {$ENDIF}
+  {$IFDEF HASAMIGA}
+  athreads,
+  {$ENDIF}
+  Interfaces, // this includes the LCL widgetset
+  Forms, main
+  { you can add units after this };
+
+{$R *.res}
+
+begin
+  RequireDerivedFormResource:=True;
+  Application.Scaled:=True;
+  Application.Initialize;
+  Application.CreateForm(TMainForm, MainForm);
+  Application.Run;
+end.
+

components/exctrls/examples/ShapeEx/main.lfm

@@ -0,0 +1,124 @@
+object MainForm: TMainForm
+  Left = 327
+  Height = 333
+  Top = 127
+  Width = 451
+  Caption = 'TShapeEx demo'
+  ClientHeight = 333
+  ClientWidth = 451
+  object ShapeEx1: TShapeEx
+    Left = 29
+    Height = 86
+    Top = 18
+    Width = 107
+    Shape = stRoundRect
+    Header.Lines.Strings = (
+      'Round Rect'
+    )
+    Header.VertAlignment = taAlignTop
+    HeaderFont.Style = [fsBold]
+    Text.Lines.Strings = (
+      'Line 1'
+      'Line 2'
+    )
+  end
+  object ShapeEx2: TShapeEx
+    Left = 160
+    Height = 86
+    Top = 18
+    Width = 120
+    Shape = stEllipse
+    Header.Lines.Strings = (
+      'Ellipse'
+    )
+    Header.VertAlignment = taAlignTop
+    HeaderFont.Style = [fsBold]
+    Text.Lines.Strings = (
+      'Line 1'
+      'Line 2'
+    )
+  end
+  object ShapeEx3: TShapeEx
+    Left = 30
+    Height = 104
+    Top = 120
+    Width = 98
+    Shape = stStar
+    Header.VertAlignment = taAlignTop
+    HeaderFont.Style = [fsBold]
+    Text.Lines.Strings = (
+      'Text'
+      'only'
+    )
+  end
+  object ShapeEx4: TShapeEx
+    Left = 160
+    Height = 104
+    Top = 120
+    Width = 120
+    Shape = stRoundRect
+    Header.Lines.Strings = (
+      'Red header'
+    )
+    Header.VertAlignment = taAlignTop
+    HeaderFont.Color = clRed
+    HeaderFont.Height = -16
+    HeaderFont.Style = [fsBold]
+    Text.Lines.Strings = (
+      'Text at top'
+    )
+    Text.VertAlignment = taAlignTop
+  end
+  object ShapeEx5: TShapeEx
+    Left = 312
+    Height = 203
+    Top = 21
+    Width = 120
+    Shape = stTriangle
+    Header.Lines.Strings = (
+      'Footer'
+    )
+    Header.VertAlignment = taAlignBottom
+    HeaderFont.Style = [fsBold]
+    Text.Lines.Strings = (
+      'Text'
+    )
+    Text.VertMargin = 0
+  end
+  object ShapeEx6: TShapeEx
+    Left = 16
+    Height = 65
+    Top = 248
+    Width = 193
+    Header.HorAlignment = taLeftJustify
+    Header.Lines.Strings = (
+      'Header (left-aligned)'
+    )
+    Header.VertAlignment = taAlignTop
+    Header.VertMargin = 6
+    HeaderFont.Style = [fsBold]
+    Text.HorAlignment = taRightJustify
+    Text.Lines.Strings = (
+      'Text (right-aligned, bottom)'
+    )
+    Text.VertAlignment = taAlignBottom
+  end
+  object ShapeEx7: TShapeEx
+    Left = 231
+    Height = 65
+    Top = 248
+    Width = 201
+    Header.HorAlignment = taRightJustify
+    Header.Lines.Strings = (
+      'Header (right-aligned)'
+    )
+    Header.VertAlignment = taAlignTop
+    Header.VertMargin = 6
+    HeaderFont.Style = [fsBold]
+    Text.HorAlignment = taLeftJustify
+    Text.Lines.Strings = (
+      'Text (left-aligned, bottom)'
+    )
+    Text.VertAlignment = taAlignBottom
+  end
+end

components/exctrls/examples/ShapeEx/main.pas

@@ -0,0 +1,36 @@
+unit main;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExShape;
+
+type
+
+  { TMainForm }
+
+  TMainForm = class(TForm)
+    ShapeEx1: TShapeEx;
+    ShapeEx2: TShapeEx;
+    ShapeEx3: TShapeEx;
+    ShapeEx4: TShapeEx;
+    ShapeEx5: TShapeEx;
+    ShapeEx6: TShapeEx;
+    ShapeEx7: TShapeEx;
+  private
+
+  public
+
+  end;
+
+var
+  MainForm: TMainForm;
+
+implementation
+
+{$R *.lfm}
+
+end.
+

components/exctrls/exctrlspkg.lpk

@@ -19,7 +19,7 @@
 - TRadioButton, TCheckbox, TRadioGroup and TCheckGroup: drawn by ThemeServices/Canvas, not by widgetset, button/text layout, wordwrap, user-provided check images
 - TColumnComboBoxEx"/>
     <License Value="LGPL with linking exception (like Lazarus LCL)."/>
-    <Files Count="7">
+    <Files Count="8">
       <Item1>
         <Filename Value="source\excheckctrls.pas"/>
         <UnitName Value="ExCheckCtrls"/>
@@ -49,6 +49,10 @@
         <Filename Value="source\exquestiondlg.pas"/>
         <UnitName Value="ExQuestionDlg"/>
       </Item7>
+      <Item8>
+        <Filename Value="source\exshape.pas"/>
+        <UnitName Value="ExShape"/>
+      </Item8>
     </Files>
     <CompatibilityMode Value="True"/>
     <LazDoc Paths="fpdoc"/>

components/exctrls/exctrlspkg.pas

@@ -9,7 +9,7 @@ interface
 
 uses
   ExCheckCtrls, ExEditCtrls, ExCtrlsReg, ExButtons, ExCombo, ExCheckCombo, 
-  ExQuestionDlg, LazarusPackageIntf;
+  ExQuestionDlg, ExShape, LazarusPackageIntf;
 
 implementation
 

components/exctrls/images/imagelist.txt

@@ -25,3 +25,6 @@ tcolumncomboboxex_200.png
 tcheckcomboboxex.png
 tcheckcomboboxex_150.png
 tcheckcomboboxex_200.png
+tshapeex.png
+tshapeex_150.png
+tshapeex_200.png

components/exctrls/source/exctrlsreg.pas

@@ -12,7 +12,7 @@ procedure Register;
 implementation
 
 uses
-  ExButtons, ExCheckCtrls, ExEditCtrls, ExCombo, ExCheckCombo;
+  ExButtons, ExCheckCtrls, ExEditCtrls, ExCombo, ExCheckCombo, ExShape;
 
 {$R exctrlsreg.res}
 
@@ -21,7 +21,8 @@ begin
   RegisterComponents('ExCtrls', [
     TButtonEx, TCheckboxEx, TRadioButtonEx, TCheckGroupEx, TRadioGroupEx,
     TFloatSISpinEditEx, TCurrSpinEditEx,
-    TColumnComboBoxEx, TCheckComboBoxEx
+    TColumnComboBoxEx, TCheckComboBoxEx,
+    TShapeEx
   ]);
 end;
 

components/exctrls/source/exshape.pas

@@ -0,0 +1,357 @@
+unit ExShape;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  Types, Graphics, Classes, SysUtils, ExtCtrls;
+
+type
+  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 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.
+