Иконки в 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.

[001538]

Содержание раздела