AGB  ·  Datenschutz  ·  Impressum  







Anmelden
Nützliche Links
Registrieren
Zurück Delphi-PRAXiS Programmierung allgemein GUI-Design mit VCL / FireMonkey / Common Controls Firemonkey Buttonleiste/Menü für z.B. Listbox (Komponente)

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

Ein Thema von t2000 · begonnen am 3. Mär 2020 · letzter Beitrag vom 3. Mär 2020
Antwort Antwort
Benutzerbild von t2000
t2000

Registriert seit: 15. Dez 2005
Ort: NRW
229 Beiträge
 
Delphi 12 Athens
 
#1

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

  Alt 3. Mär 2020, 09:48
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
Thomas
(Wir suchen eine(n) Entwickler(in) mit Ambitionen später ggf. die Softwarefirma zu leiten)
Aktuell nicht mehr. Aber ab vielleicht 2024/2025 wird das wieder sehr interessant!
  Mit Zitat antworten Zitat
Benutzerbild von t2000
t2000

Registriert seit: 15. Dez 2005
Ort: NRW
229 Beiträge
 
Delphi 12 Athens
 
#2

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

  Alt 3. Mär 2020, 09:49
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.
Thomas
(Wir suchen eine(n) Entwickler(in) mit Ambitionen später ggf. die Softwarefirma zu leiten)
Aktuell nicht mehr. Aber ab vielleicht 2024/2025 wird das wieder sehr interessant!
  Mit Zitat antworten Zitat
Themen-Optionen Thema durchsuchen
Thema durchsuchen:

Erweiterte Suche
Ansicht

Forumregeln

Es ist dir nicht erlaubt, neue Themen zu verfassen.
Es ist dir nicht erlaubt, auf Beiträge zu antworten.
Es ist dir nicht erlaubt, Anhänge hochzuladen.
Es ist dir nicht erlaubt, deine Beiträge zu bearbeiten.

BB-Code ist an.
Smileys sind an.
[IMG] Code ist an.
HTML-Code ist aus.
Trackbacks are an
Pingbacks are an
Refbacks are aus

Gehe zu:

Impressum · AGB · Datenschutz · Nach oben
Alle Zeitangaben in WEZ +1. Es ist jetzt 19:35 Uhr.
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
LinkBacks Enabled by vBSEO © 2011, Crawlability, Inc.
Delphi-PRAXiS (c) 2002 - 2023 by Daniel R. Wolf, 2024 by Thomas Breitkreuz