Иконки в PopupMenu

Code:

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;

Code:

{

В меню существуют некоторые проблемы масштабированием и палитрой иконки.

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

Листинг был изменен для того, чтобы помещать иконки в "чЕкнутое"

состояние меню(просто это делает 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.