Criando MENU em tempo de execução com VCL Theme aplicado = Erro

15/02/2021

0

Boa noite galera.

Quando criado menu em tempo de execução e em seguida aplicando um tema da VCL, os menos estão ficando desconfigurados.

1 - Imagem com menu em tempo de execução sem TEMA ATIVO = OK.
https://uploaddeimagens.com.br/imagens/tNXtYTY


2 - Imagem com menu em tempo de execução com TEMA ATIVO = ERRO.
https://uploaddeimagens.com.br/imagens/3d5kcRA

Seguem código de é gerado o carregamento dos dados:
unit UFormPrincipal;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, System.Actions,
  Vcl.ActnList, Vcl.Menus, System.ImageList, Vcl.ImgList, cxImageList,
  cxGraphics, UdmLista, Vcl.ComCtrls, Vcl.ToolWin;

type
  TFormPrincipal = class(TForm)
    btnAplicar: TButton;
    btnCarregarTema: TButton;
    btnCriarMenus: TButton;
    pgnModulos: TPageControl;
    ToolBarOne: TToolBar;
    procedure btnAplicarClick(Sender: TObject);
    procedure btnCarregarTemaClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure btnCriarMenusClick(Sender: TObject);
  private
    { Private declarations }
    FModuloLista: TdmLista;
  public
    { Public declarations }
  end;

var
  FormPrincipal: TFormPrincipal;

implementation

Uses
  Vcl.Styles,
  Vcl.Themes;

{$R *.dfm}

procedure TFormPrincipal.btnAplicarClick(Sender: TObject);
begin
  if btnAplicar.Caption = 'Aplicar CARBON' then begin
    btnAplicar.Caption := 'Aplicar WINDOWS';
    TStyleManager.TrySetStyle('Carbon');
  end else begin
    btnAplicar.Caption := 'Aplicar CARBON';
    TStyleManager.TrySetStyle('Windows');
  end;
end;

procedure TFormPrincipal.btnCarregarTemaClick(Sender: TObject);
begin
  TStyleManager.LoadFromFile('C:\Users\Jozimar\Desktop\TST\Tema\Carbon.vsf');
end;

procedure TFormPrincipal.btnCriarMenusClick(Sender: TObject);
var
  lMenu: TMainMenu;
  lItem: TMenuItem;
  lIndex: iNTEGER;
  TabSheet: TTabSheet;
begin
  TabSheet := TTabSheet.Create(pgnModulos);
  TabSheet.PageControl := pgnModulos;
  TabSheet.Caption := '  - Menu - ';


  ToolBarOne.Parent := TabSheet;

  lMenu := TMainMenu.Create(ToolBarOne);
  lMenu.Images := FModuloLista.ImageList1;

  lItem := TMenuItem.Create(lMenu);
  lItem.Caption := '    -- SubMenu --   ';
  lMenu.Items.Add(lItem);

  for lIndex := 0 to FModuloLista.ActionList1.ActionCount-1 do begin
    lItem := TMenuItem.Create(lMenu);
    lItem.Action := FModuloLista.ActionList1[lIndex];
    lMenu.Items[0].Add(lItem);
  end;

  ToolBarOne.Menu := lMenu;
end;

procedure TFormPrincipal.FormCreate(Sender: TObject);
begin
  FModuloLista := TdmLista.Create(Self);
end;

end.



E esse DataModule:
unit UdmLista;

interface

uses
  System.SysUtils, System.Classes, System.ImageList, Vcl.ImgList, Vcl.Controls,
  cxImageList, cxGraphics, System.Actions, Vcl.ActnList, Vcl.Menus;

type
  TdmLista = class(TDataModule)
    ActionList1: TActionList;
    Action1: TAction;
    Action2: TAction;
    Action3: TAction;
    Action4: TAction;
    ImageList1: TImageList;
    MainMenuOne: TMainMenu;
    Novidades1: TMenuItem;
    Action11: TMenuItem;
    Action21: TMenuItem;
    Action31: TMenuItem;
    Action41: TMenuItem;
    procedure Action1Execute(Sender: TObject);
    procedure Action2Execute(Sender: TObject);
    procedure Action3Execute(Sender: TObject);
    procedure Action4Execute(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  dmLista: TdmLista;

implementation

Uses
  Vcl.Dialogs;

{%CLASSGROUP 'Vcl.Controls.TControl'}

{$R *.dfm}

procedure TdmLista.Action1Execute(Sender: TObject);
begin
  ShowMessage('1111');
end;

procedure TdmLista.Action2Execute(Sender: TObject);
begin
  ShowMessage('2222');
end;

procedure TdmLista.Action3Execute(Sender: TObject);
begin
  ShowMessage('3333');
end;

procedure TdmLista.Action4Execute(Sender: TObject);
begin
  ShowMessage('4444');
end;

end.



O que pode estar causando isso ?
Jozimar

Jozimar

Responder

Utilizamos cookies para fornecer uma melhor experiência para nossos usuários, consulte nossa política de privacidade.

Aceitar