Иконки в PopupMenu . Delphi , Компоненты и Классы , Меню

Delphi , Компоненты и Классы , Меню

Иконки в PopupMenu

type

  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    // * * * * Элемент для Menu Bar * * * * /
      Open1: TMenuItem;
    // * * * * Элемент для Menu file * * * * /
      procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    {private declarations}
  public
    {public declarations}
    Icn, Txt, MnuItm: TBitmap;
  end;

procedure TForm2.FormCreate(Sender: TObject);
var
  R: TRect;

  HIcn: HIcon;
  Ic: TIcon;
  Index: Word;
  FileName: PChar;
begin

  // * * Получаем иконку определенного приложения * * /
    Ic := TIcon.Create;
  Ic.Handle := ExtractAssociatedIcon(Hinstance, // * задаем путь и имя файла * /
    , Index);
  // * * Создаем для текста изображение * * /
    Txt := TBitmap.Create;
  with Txt do
  begin
    Width := Canvas.TextWidth(' Тест');
    Height := Canvas.TextHeight(' Тест');
    Canvas.TextOut(0, 0, ' Тест');
  end;

  // * * Копируем иконку в bitmap для изменения его размера.
    Вы не можете менять размер иконки * * /
    Icn := TBitmap.Create;
  with Icn do
  begin
    Width := 32;
    Height := 32;
    Brush.Color := clBtnFace;
    Canvas.Draw(0, 0, Ic);
  end;

  // * * Создаем окончательное изображение, куда мы помещаем иконку и текст * * /
    MnuItm := TBitmap.Create;
  with MnuItm do
  begin
    Width := Txt.Width + 18;
    Height := 18;
    with Canvas do
    begin
      Brush.Color := clBtnFace;
      Pen.Color := clBtnFace;
      Brush.Style := bsSolid;
      Rectangle(0, 0, Width, Height);
      CopyMode := cmSrcAnd;
      StretchDraw(Rect(0, 0, 16, 16), Icn);
      CopyMode := cmSrcAnd;
      Draw(16, 8 - (Txt.Height div 2), Txt);
    end;
  end;
end;

procedure TForm2.FormShow(Sender: TObject);
var

  ItemInfo: TMenuItemInfo;
  hBmp1: THandle;
begin

  HBmp1 := MnuItm.Handle;
  with ItemInfo do
  begin
    cbSize := SizeOf(ItemInfo);
    fMask := MIIM_TYPE;
    fType := MFT_BITMAP;
    dwTypeData := PChar(MakeLong(hBmp1, 0));
  end;

  // * * Заменяем MenuItem Open1 законченным изображением * *
    SetMenuItemInfo(GetSubMenu(MainMenu1.Handle, File1.MenuIndex),
      Open1.MenuIndex, true, ItemInfo);

end;

{
В меню существуют некоторые проблемы масштабированием и палитрой иконки.
  Я также ищу лучшее решение, но это все, что я вам могу сейчас дать.

Листинг был изменен для того, чтобы помещать иконки в "чЕкнутое"
  состояние меню(просто это делает Win95).Это позволяет вам иметь
  "чЕкнутое" и "нечЕкнутое" состояние.
}

unit Unit1;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus, ShellAPI;

type

  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    Open1: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    Icn, MnuItm: TBitmap;
  end;

var

  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
  R: TRect;

  HIcn: HIcon;
  Ic: TIcon;
  Index: Word;
begin

  {     /** Получаем иконку некоторого приложения **/}

  Index := 0; { 11-я иконка в файле }
  Ic := TIcon.Create;
  Ic.Handle := ExtractAssociatedIcon(Hinstance,
    'c:\win95\system\shell32.dll', Index);

  {     /** Копируем иконку в bitmap для изменения его размера.
  Вы не можете менять размер иконки **/}

  Icn := TBitmap.Create;

  with Icn do
  begin
    Width := 32;
    Height := 32;
    Canvas.Brush.Color := clbtnface;
    Canvas.Draw(0, 0, Ic);
  end;

  {     /** Создаем окончательное изображение, куда мы помещаем иконку и текст **/}

  MnuItm := TBitmap.Create;
  with MnuItm do
  begin
    Width := 18;
    Height := 18;
    with Canvas do
    begin
      Brush.Color := clbtnface;
      Pen.Color := clbtnface;
      CopyMode := cmSrcAnd;
      StretchDraw(Rect(0, 0, 16, 16), Icn);
    end;
  end;
end;

procedure TForm1.FormShow(Sender: TObject);
var
  ItemInfo: TMenuItemInfo;
  hBmp1: THandle;
begin
  HBmp1 := MnuItm.Handle;
  with ItemInfo do
  begin
    cbSize := SizeOf(ItemInfo);
    fMask := MIIM_CHECKMARKS;
    fType := MFT_BITMAP;
    hBmpunChecked := HBmp1; { Неотмеченное (Unchecked) состояние }
    hBmpChecked := HBmp1; { Отмеченное (Checked) состояние }
  end;

  {     /** Заменяем MenuItem Open1 законченным изображением **/}

  SetMenuItemInfo(GetSubMenu(MainMenu1.Handle, File1.MenuIndex),
    Open1.MenuIndex, true, ItemInfo);
end;

end.

Привет! Я перевёл текст на русский язык:

Код, который вы предоставили, это старый проект Delphi, использующий Windows API для установки иконок в контекстном меню. Он создает биты для иконок и затем устанавливает их как элементы меню.

Однако, есть некоторые проблемы с этим кодом:

Процесс извлечения иконок можно улучшить с помощью функции ExtractIcon вместо ExtractAssociatedIcon.

Создание битмапов не оптимизировано, так как оно涉гает создание нескольких битмапов и копирование данных между ними.

Код не обрабатывает ошибки должным образом.

Вот обновлённая версия кода, которая решает эти проблемы:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Menus, ShellAPI;

type
  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    Open1: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    Icn, MnuItm: TBitmap;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
  R: TRect;
  HIcn: HIcon;
begin
  // Извлечь иконку из shell32.dll
  HIcn := ExtractIcon(0, 'c:\win95\system\shell32.dll', 11);

  Icn := TBitmap.Create;
  try
    with Icn do
    begin
      Width := 32;
      Height := 32;
      Canvas.Brush.Color := clBtnFace;
      Canvas.Draw(0, 0, HIcn);
    end;
  finally
    FreeAndNil(HIcn);
  end;

  MnuItm := TBitmap.Create;
  try
    with MnuItm do
    begin
      Width := 18;
      Height := 18;
      Canvas.Brush.Color := clBtnFace;
      CopyMode := cmSrcAnd;
      StretchDraw(Rect(0, 0, 16, 16), Icn);
    end;
  finally
    FreeAndNil(Icn);
  end;
end;

procedure TForm1.FormShow(Sender: TObject);
var
  ItemInfo: TMenuItemInfo;
  hBmp1: THandle;
begin
  hBmp1 := MnuItm.Handle;
  with ItemInfo do
  begin
    cbSize := SizeOf(ItemInfo);
    fMask := MIIM_CHECKMARKS;
    fType := MFT_BITMAP;
    hBmpUnchecked := hBmp1;
    hBmpChecked := hBmp1;
  end;

  SetMenuItemInfo(GetSubMenu(MainMenu1.Handle, File1.Index),
    Open1.Index, true, ItemInfo);
end;

end.

В обновлённом коде:

Я заменил функцию ExtractAssociatedIcon на ExtractIcon, которая более эффективна и гибкая.

Я удалил ненужное создание нескольких битмапов и вместо этого создал одиночный битмап для каждой иконки.

Я добавил обработку ошибок с помощью блоков try...finally для обеспечения правильного освобождения памяти, даже в случае исключений.

Обратите внимание, что вам нужно будет адаптировать процесс извлечения иконок в соответствии со своими конкретными требованиями.

Иконки в PopupMenu: статья описывает способ размещения иконок в пунктах меню приложения Delphi, с учетом масштабирования и палитры иконки.

Комментарии и вопросы

Получайте свежие новости и обновления по Object Pascal, Delphi и Lazarus прямо в свой смартфон. Подпишитесь на наш

Telegram-канал delphi_kansoftware и будьте в курсе последних тенденций в разработке под Linux, Windows, Android и iOS