Firemonkey Buttonleiste/Menü für z.B. Listbox (Komponente)

[t2000]

Hallo Leute,

Firemonkey ist für mich neu und auf Delphi 10 bin ich auch erst vor 3 Jahren von Delphi 7 umgestiegen. Und in der Zeit habe ich nur mein altes Projekt angepasst bzw. gepflegt. Also nichts Neues gemacht.

Ich hatte hier vor, eine Komponente zu machen, die bei Listboxen (oder ähnliches) oben drüber steht und als Menü/Buttonleiste arbeiten soll. Einige Sourcen für die Entwicklung habe ich hier aus anderen Themen kopiert (OwnedCollection).
Ganz so schnell wie ich gedacht hatte, bekomme ich das jetzt aber nicht hin und meine Zeit läuft schon wieder davon. Daher stelle ich das hier einfach mal rein. Vielleicht möchte ja jemand das Gerüst benutzen und zu Ende programmieren, bzw. so viel Hilfe leisten, dass ich es selber schaffe.

Die Komponente basiert auf einem TFlowLayout und hat als Inhalt eine Collection von TRectangles mit einem TImage und einem TLabel.
Visuell kann ich die Collection aufbauen und auch verschiedene Einstellungen machen. Wer den Code liest, sollte recht schnell die Einstellungen und Möglichkeiten verstehen.
Aktuell bekomme ich zur Entwicklung und zur Laufzeit immer einige (tote) Rechtecke zuviel, obwohl das TRectangle.Create in der richtigen Anzahl aufgerufen wird.
Die Events fehlen größtenteils noch und die Größenanpassung habe ich aus meinem ersten Testprogramm (ohne Komponente) als Kommentar am Ende eingefügt.

Also, wenn jemand Interesse/Lust hat sich damit zu beschäftigen wäre super. Bei mir fehlt gerade echt die Zeit.

Der Sourcecode folgt hier drunter.

Viele Grüße
Thomas

[t2000]

Delphi-Quellcode:

unit sng.ListboxMenu;

interface

uses
  System.Classes, System.Types, System.UITypes, System.Imagelist, System.Generics.Collections,
  //System.Contnrs,
  System.WideStrings, System.SysUtils,
  FMX.Types, FMX.Graphics, FMX.StdCtrls, FMX.Objects, FMX.Layouts, FMX.ImgList, FMX.Utils, FMX.ActnList;

type
  TsngListMenuItem = class;

  TsngListMenuItemCollection = class( TOwnedCollection)
  private
    FParentItem     : TsngListMenuItem;
    function  GetItem(Index: Integer): TsngListMenuItem;
    procedure SetItem(Index: Integer; Value: TsngListMenuItem);
  protected
    procedure SetItemName(AItem: TCollectionItem); override;
  public
    constructor Create(AOwner: TPersistent); virtual;
    procedure GetItemNames(List: Tstrings); overload;
    procedure GetItemNames(List: TWideStrings); overload;

    property Items[Index: Integer] : TsngListMenuItem read GetItem write SetItem; default;
    property ParentItem            : TsngListMenuItem read FParentItem;
  end;

  TsngListMenuItem = class( TCollectionItem)
  private
    FmiRectangle : TRectangle;
    FmiImage     : TImage;
    FmiLabel     : TLabel;

    FColor       : TAlphaColor;
    FColorHot    : TAlphaColor;
    FImageIndex  : Integer;
    FName        : String;

    procedure Clear;
    procedure SetColor(const Value: TAlphaColor);
    procedure SetColorHot(const Value: TAlphaColor);
    procedure SetImageIndex(const Value: Integer);
  protected
    function GetDisplayName: string; override;
    procedure SetDisplayName(const Value: string); reintroduce;

    procedure miRectangleClick(Sender: TObject);
    procedure miRectangleMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
    procedure miRectangleMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
    procedure miRectangleMouseEnter(Sender: TObject);
    procedure miRectangleMouseLeave(Sender: TObject);
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
//    procedure DrawItem;
  published
    property Color      : TAlphaColor read FColor      write SetColor;
    property ColorHot   : TAlphaColor read FColorHot   write SetColorHot;
    property Imageindex : Integer     read FImageIndex write SetImageIndex;
    property Name       : String      read FName       write SetDisplayName;

  end;

  TLBMenuitemSettings = class(TPersistent)
  private
    FHeight       : Integer;
    FWidth        : Integer;
    FMargins      : TBounds;

    FImageHeight  : Integer;
    FImageWidth   : Integer;
    FImageMargins : TBounds;

    FTextSettings : TTextSettings;
    FTextMargins  : TBounds;

    procedure SetHeight(const Value: Integer);
    procedure SetWidth(const Value: Integer);
    function  GetMargins: TBounds;
    procedure SetMargins(const Value: TBounds);

    procedure SetImageHeight(const Value: Integer);
    procedure SetImageWidth(const Value: Integer);
    function  GetImageMargins: TBounds;
    procedure SetImageMargins(const Value: TBounds);

    function  GetTextSettings: TTextSettings;
    procedure SetTextSettings(const Value: TTextSettings);
    function  GetTextMargins: TBounds;
    procedure SetTextMargins(const Value: TBounds);

  public
    constructor Create(AOwner: TComponent); virtual;
    destructor Destroy;
    procedure Assign(Source: TPersistent); override;

  published
    property Height       : Integer       read FHeight         write SetHeight;
    property Width        : Integer       read FWidth          write SetWidth;
    property Margins      : TBounds       read GetMargins      write SetMargins;

    property ImageHeight  : Integer       read FImageHeight    write SetImageHeight;
    property ImageWidth   : Integer       read FImageWidth     write SetImageWidth;
    property ImageMargins : TBounds       read GetImageMargins write SetImageMargins;

    property TextSettings : TTextSettings read GetTextSettings write SetTextSettings;
    property TextMargins  : TBounds       read GetTextMargins  write SetTextMargins;
  end;

  TsngListMenu = class( TFlowLayout, IGlyph)
  private
    [Weak] FImages    : TCustomImageList;
    FImageLink        : TGlyphImageLink;

    FActiveMenuItem   : TsngListMenuItem;
    FMenu             : TsngListMenuItemCollection;
    FMenuitemSettings : TLBMenuitemSettings;
    function  GetMenuitemSettings: TLBMenuitemSettings;
    procedure SetMenuitemSettings(const Value: TLBMenuitemSettings);
  private
    { IGlyph }
    function GetImageIndex: TImageIndex;
    procedure SetImageIndex(const Value: TImageIndex);
    function GetImageList: TBaseImageList; inline;
    procedure SetImageList(const Value: TBaseImageList);
    function IGlyph.GetImages = GetImageList;
    procedure IGlyph.SetImages = SetImageList;
    procedure SetImages(const Value: TCustomImageList);
    function GetImages: TCustomImageList;
  protected
    procedure ImagesChanged; virtual;
//    procedure Paint; override;
    procedure SetMenu(Value: TsngListMenuItemCollection);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure AssignTo(Dest: TPersistent);
    property ActiveMenuItem : TsngListMenuItem read FActiveMenuItem write FActiveMenuItem;
  published
    property Align;
    property Anchors;
    property ClipChildren;
    property ClipParent;
    property Cursor;
    property DragMode;
    property EnableDragHighlight;
    property Enabled;
    property Locked;
    property Height;
    property HitTest;
    property Images           : TCustomImageList    read GetImages           write SetImages;
    property Margins;
    property Menu: TsngListMenuItemCollection read FMenu write SetMenu;
    property MenuitemSettings : TLBMenuitemSettings read GetMenuitemSettings write SetMenuitemSettings;
    property Opacity;
    property Padding;
    property PopupMenu;
    property Position;
    property RotationAngle;
    property RotationCenter;
    property Scale;
    property Size;
    property TouchTargetExpansion;
    property Visible;
    property Width;
    property TabOrder;
    property TabStop;
    property Justify;
    property JustifyLastLine;
    property FlowDirection;
    property HorizontalGap;
    property VerticalGap;
    {Drag and Drop events}
    property OnDragEnter;
    property OnDragLeave;
    property OnDragOver;
    property OnDragDrop;
    property OnDragEnd;
    {Mouse events}
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheel;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnPainting;
    property OnPaint;
    property OnResize;
    property OnResized;
  end;

procedure Register;

implementation

{ TsngListMenuItemCollection }

constructor TsngListMenuItemCollection.Create(AOwner: TPersistent);
begin
  FParentItem := nil;
  if AOwner is TsngListMenuItem then
    FParentItem := TsngListMenuItem(AOwner);
  inherited Create(AOwner, TsngListMenuItem);
end;

function TsngListMenuItemCollection.GetItem(Index: Integer): TsngListMenuItem;
begin
  Result := TsngListMenuItem(inherited Items[Index]);
end;

procedure TsngListMenuItemCollection.GetItemNames(List: Tstrings);
var
  wList: TWIdeStringList;
begin
  wList := TWIdeStringList.Create;
  try
    GetItemNames(wList);
    List.Assign(wList);
  finally
    wList.Free;
  end;
end;

procedure TsngListMenuItemCollection.GetItemNames(List: TWideStrings);
var
  I: Integer;
begin
  List.BeginUpdate;
  try
    List.Clear;
    for I := 0 to Count - 1 do
      with TsngListMenuItem(Items[I]) do
        if Name <> '' then List.Add(Name);
  finally
    List.EndUpdate;
  end;
end;

procedure TsngListMenuItemCollection.SetItem(Index: Integer; Value: TsngListMenuItem);
begin
  inherited Items[Index] := Value;
end;

procedure TsngListMenuItemCollection.SetItemName(AItem: TCollectionItem);
begin
  inherited SetItemName(AItem);
// if Value is TTestCollectionItem then
// begin
// if TTestCollectionItem(AItem).Name = '' then
// TTestCollectionItem(AItem).Name := Copy(ClassName, 2, 5) + IntToStr(ID + 1);
// end;
end;

{ TsngListMenuItem }

procedure TsngListMenuItem.Assign(Source: TPersistent);
var
  I: Integer;
  S: TsngListMenuItem;
begin
  if Source is TsngListMenuItem then
  begin
    if Collection <> nil then Collection.BeginUpdate;
    try
      S := TsngListMenuItem(Source);
      FmiRectangle := S.FmiRectangle;
      FmiImage     := S.FmiImage;
      FmiLabel     := S.FmiLabel;
      ImageIndex   := S.FImageIndex;
      Name         := S.Name;
    finally
      if Collection <> nil then Collection.EndUpdate;
    end;
  end else inherited;
end;

procedure TsngListMenuItem.Clear;
begin

end;

constructor TsngListMenuItem.Create(Collection: TCollection);

// !! Achtung, hier ist noch Testcode, Zufallsfarben usw.

begin
  inherited Create(Collection);
  FmiRectangle := TRectangle.Create(TsngListMenu(TsngListMenuItemCollection(Collection).GetOwner));
  FmiRectangle.Parent         := TFMXObject(FmiRectangle.Owner);
  //FmiRectangle.Fill.Kind      := TBrushKind.None;
  FmiRectangle.Fill.Kind      := TBrushKind.Solid;
  FmiRectangle.Fill.Color      := TAlphaColor($FF000000) or (TAlphaColor(256*256*random(256)+256*random(256)+random(256)));
  FmiRectangle.Margins.Left   := 5;
  FmiRectangle.Margins.Top    := 1;
  FmiRectangle.Margins.Right  := 5;
  FmiRectangle.Margins.Bottom := 1;
  FmiRectangle.Position.X     := 5;
  FmiRectangle.Position.Y     := 1;
  FmiRectangle.Size.Width     := 120;
  FmiRectangle.Size.Height    := 25;
  FmiRectangle.Size.PlatformDefault := False;
  FmiRectangle.Stroke.Kind    := TBrushKind.None;
  FmiRectangle.OnClick        := miRectangleClick;
  FmiRectangle.OnMouseDown    := miRectangleMouseDown;
  FmiRectangle.OnMouseUp      := miRectangleMouseUp;
  FmiRectangle.OnMouseEnter   := miRectangleMouseEnter;
  FmiRectangle.OnMouseLeave   := miRectangleMouseLeave;

  FmiImage := TImage.Create(FmiRectangle);
  FmiImage.Parent             := FmiRectangle;
  FmiImage.Align              := TAlignLayout.Left;
  FmiImage.HitTest            := False;
  FmiImage.Margins.Left       := 3;
  FmiImage.Margins.Top        := 3;
  FmiImage.Margins.Right      := 3;
  FmiImage.Margins.Bottom     := 3;
  FmiImage.Position.X         := 3;
  FmiImage.Position.Y         := 3;
  FmiImage.Size.Width         := 19;

  FmiLabel := TLabel.Create(FmiRectangle);
  FmiLabel.Parent             := FmiRectangle;
  FmiLabel.Align              := TAlignLayout.Client;
  FmiLabel.HitTest            := False;
  FmiLabel.Margins.Left       := 8;

  FmiLabel.Text       := IntToStr(random(1000));
end;

destructor TsngListMenuItem.Destroy;
begin
  FmiLAbel.Free;
  FmiImage.Free;
  FmiRectangle.Free;
  inherited Destroy;
end;

//procedure TsngListMenuItem.DrawItem;
//begin
//  FmiRectangle.Visible := true;
////    FmiImage     : TImage;
//  //  FmiLabel     : TLabel;
//end;

function TsngListMenuItem.GetDisplayName: string;
begin
  Result := FName;
end;

procedure TsngListMenuItem.miRectangleClick(Sender: TObject);
begin
//  if Sender = activeComponent then begin
//    ShowMessage(TComponent(Sender).Name+': Mouse Up');
//  end;
  TsngListMenu(TRectangle(Sender).Owner).ActiveMenuItem := nil;
  (Sender as TRectangle).Fill.Color := Color;
  TRectangle(Sender).Repaint;
end;

procedure TsngListMenuItem.miRectangleMouseLeave(Sender: TObject);
begin
  (Sender as TRectangle).Fill.Kind := TBrushKind.None;
  TRectangle(Sender).Repaint;
end;

procedure TsngListMenuItem.miRectangleMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
  TsngListMenu(TRectangle(Sender).Owner).ActiveMenuItem := self;
  (Sender as TRectangle).Fill.Color := ColorHot;
  TRectangle(Sender).Repaint;
end;

procedure TsngListMenuItem.miRectangleMouseEnter(Sender: TObject);
begin
  (Sender as TRectangle).Fill.Kind := TBrushKind.Solid;
  if TsngListMenu(TRectangle(Sender).Owner).ActiveMenuItem = TsngListMenu(TsngListMenuItemCollection(Collection).Owner).ActiveMenuItem
    then (Sender as TRectangle).Fill.Color := ColorHot
    else (Sender as TRectangle).Fill.Color := Color;
  TRectangle(Sender).Repaint;
end;

procedure TsngListMenuItem.miRectangleMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
  TsngListMenu(Collection.Owner).ActiveMenuItem := nil;
  TRectangle(Sender).Repaint;
end;

procedure TsngListMenuItem.SetColor(const Value: TAlphaColor);
begin
  FColor := Value;
end;

procedure TsngListMenuItem.SetColorHot(const Value: TAlphaColor);
begin
  FColorHot := Value;
end;

procedure TsngListMenuItem.SetDisplayName(const Value: string);
begin
  FName := Value;
  FmiLabel.Text := Value;
  inherited SetDisplayName(Value);
end;

procedure TsngListMenuItem.SetImageIndex(const Value: Integer);
begin
  FImageIndex := Value;
end;

{ TLBMenuitemSettings }

procedure TLBMenuitemSettings.Assign(Source: TPersistent);
begin
  if (Source is TLBMenuitemSettings) then
  begin
    FHeight       := (Source as TLBMenuitemSettings).Height;
    FWidth        := (Source as TLBMenuitemSettings).Width;
    FMargins      := (Source as TLBMenuitemSettings).Margins;

    FImageHeight  := (Source as TLBMenuitemSettings).ImageHeight;
    FImageWidth   := (Source as TLBMenuitemSettings).ImageWidth;
    FImageMargins := (Source as TLBMenuitemSettings).ImageMargins;

    FTextSettings := (Source as TLBMenuitemSettings).TextSettings;
    FTextMargins  := (Source as TLBMenuitemSettings).TextMargins;
  end;

end;

constructor TLBMenuitemSettings.Create(AOwner: TComponent);
var
  r : TRectF;
begin
  inherited Create;
  FHeight       := 25;
  FImageHeight  := 19;
  FImageMargins := TBounds.Create( TRectF.Create(3,3,3,3));
  FImageWidth   := 19;
  FMargins      := TBounds.Create( TRectF.Create(5,1,5,1));
  FTextMargins  := TBounds.Create( TRectF.Create(8,0,0,0));
  FTextSettings := TTextSettings.Create(self);
  FWidth        := 120;
end;

destructor TLBMenuitemSettings.Destroy;
begin
  FTextSettings.Free;
  FTextMargins.Free;
  FMargins.Free;
  FImageMargins.Free;
  inherited Destroy;
end;

function TLBMenuitemSettings.GetImageMargins: TBounds;
begin
  Result := FImageMargins;
end;

function TLBMenuitemSettings.GetMargins: TBounds;
begin
  Result := FMargins;
end;

function TLBMenuitemSettings.GetTextMargins: TBounds;
begin
  Result := FTextMargins;
end;

function TLBMenuitemSettings.GetTextSettings: TTextSettings;
begin
  Result := FTextSettings;
end;

procedure TLBMenuitemSettings.SetHeight(const Value: Integer);
begin
  FHeight := Value;
end;

procedure TLBMenuitemSettings.SetImageHeight(const Value: Integer);
begin
  FImageHeight := Value;
end;

procedure TLBMenuitemSettings.SetImageMargins(const Value: TBounds);
begin
  FImageMargins.Assign(Value);
end;

procedure TLBMenuitemSettings.SetImageWidth(const Value: Integer);
begin
  FImageWidth := Value;
end;

procedure TLBMenuitemSettings.SetMargins(const Value: TBounds);
begin
  FMargins.Assign(Value);
end;

procedure TLBMenuitemSettings.SetTextMargins(const Value: TBounds);
begin
  FTextMargins.Assign(Value);
end;

procedure TLBMenuitemSettings.SetTextSettings(const Value: TTextSettings);
begin
  FTextSettings := Value;
end;

procedure TLBMenuitemSettings.SetWidth(const Value: Integer);
begin
  FWidth := Value;
end;

{ TsngListMenu }

procedure TsngListMenu.AssignTo(Dest: TPersistent);
begin
  if Dest is TsngListMenu then
  begin
    TsngListMenu(Dest).FMenu.Assign(FMenu);
  end
  else
    inherited AssignTo(Dest);
end;

constructor TsngListMenu.Create(AOwner: TComponent);
begin
  inherited;
  FMenuitemSettings := TLBMenuitemSettings.Create(self);
  FImageLink        := TGlyphImageLink.Create(Self);

  FActiveMenuItem   := nil;
  FMenu             := TsngListMenuItemCollection.Create(Self);

  Align             := TAlignLayout.Top;
  Justify           := TFlowJustify.Left;
  JustifyLastLine   := TFlowJustify.Left;
  FlowDirection     := TFlowDirection.LeftToRight;

end;

destructor TsngListMenu.Destroy;
begin
  FreeAndNil(FMenu);
  FMenuitemSettings.Free;
  FImageLink.DisposeOf;
  inherited;
end;

function TsngListMenu.GetImageIndex: TImageIndex;
begin
  Result := -1
end;

function TsngListMenu.GetImageList: TBaseImageList;
begin
  Result := FImageLink.Images;
end;

function TsngListMenu.GetImages: TCustomImageList;
begin
  Result := TCustomImageList(FImageLink.Images);
end;

function TsngListMenu.GetMenuitemSettings: TLBMenuitemSettings;
begin
  Result := FMenuitemSettings;
end;

procedure TsngListMenu.ImagesChanged;
var
  I: Integer;
begin
//  for I := 0 to FsngMenu.Count - 1 do
//    FsngMenu.Items[I].Changed;
end;

//procedure TsngListMenu.Paint;
//var
//  i: Integer;
//  item: TsngListMenuItem;
//begin
//  inherited;
//  for i := 0 to FMenu.Count-1 do
//    FMenu.Items[i].DrawItem;
//end;

procedure TsngListMenu.SetImageIndex(const Value: TImageIndex);
begin
  // none
end;

procedure TsngListMenu.SetImageList(const Value: TBaseImageList);
begin
  ValidateInheritance(Value, TCustomImageList, True);
  FImageLink.Images := Value;
end;

procedure TsngListMenu.SetImages(const Value: TCustomImageList);
begin
  FImageLink.Images := Value;
end;

procedure TsngListMenu.SetMenu(Value: TsngListMenuItemCollection);
begin
  FMenu.Assign(Value);
end;

procedure TsngListMenu.SetMenuitemSettings(const Value: TLBMenuitemSettings);
begin
  FMenuitemSettings.Assign( Value);
end;

procedure Register;
begin
  RegisterComponents('Eigene', [TsngListMenu]);
end;

(*
procedure TffServices.FlowLayoutHeaderResize(Sender: TObject);
var
  NewHeight : Single;
begin
  NewHeight := 25 * trunc(AnzServiceButton / trunc(FlowLayoutHeader.Size.Width / (ServiceButtonWidth+10)) + 0.999999);
  if NewHeight <> FlowLayoutHeader.Size.Height then
    FlowLayoutHeader.Size.Height := NewHeight;
end;
*)

end.