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

[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.