Валентин Озеров - Советы по Delphi. Версия 1.4.3 от 1.1.2001

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

procedureTfrmExplorer.TreeViewMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

varP : TPoint;

begin

if Button<>mbRight thenexit;

TreeMenu.AutoPopup := False;

ifTreeView.GetNodeAt(X,Y)<>NIL then begin

TreeView.Selected := TreeView.GetNodeAt(X,Y);

P.X := X;

P.Y:=Y;

P := TreeView.ClientToScreen(P);

TreeMenu.Popup(P.X,P.Y);

end;

end;

typeTForm1 = class(TForm)

MainMenu1: TMainMenu;

File1: TMenuItem; /**** Элемент для Menu Bar ****/

Open1: TMenuItem; /**** Элемент для Menu File ****/

procedureFormCreate(Sender: TObject);

procedureFormShow(Sender: TObject);

private

{private declarations}

public

{public declarations}

Icn, Txt, MnuItm: TBitmap;

end;

procedureTForm2.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;

withTxt do begin

Width:=Canvas.TextWidth(' Тест');

Height:=Canvas.TextHeight(' Тест');

Canvas.TextOut(0, 0, ' Тест');

end;

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

Icn:=TBitmap.Create;

withIcn do begin

Width:=32;

Height:=32;

Brush.Color:=clBtnFace;

Canvas.Draw(0, 0, Ic);

end;

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

MnuItm:=TBitmap.Create;

withMnuItm do begin

Width:=Txt.Width+18;

Height:=18;

withCanvas 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 div2), Txt);

end;

end;

end;

procedureTForm2.FormShow(Sender: TObject);

var

ItemInfo: TMenuItemInfo;

hBmp1 : THandle;

begin

HBmp1:=MnuItm.Handle;

withItemInfo 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). Это позволяет вам иметь «чЕкнутое» и «нечЕкнутое» состояние.

unitUnit1;

interface

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

typeTForm1 = class(TForm)

MainMenu1: TMainMenu;

File1: TMenuItem;

Open1: TMenuItem;

procedureFormCreate(Sender: TObject);

procedureFormShow(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

Icn, MnuItm : TBitmap;

end;

varForm1: TForm1;

implementation

{$R *.DFM}

procedureTForm1.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;

withIcn do begin

Width:=32;

Height:=32;

Canvas.Brush.Color := clbtnface;

Canvas.Draw(0,0,Ic);

end;

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

MnuItm:=TBitmap.Create;

withMnuItm do begin

Width :=18;

Height:=18;

withCanvas do begin

Brush.Color:=clbtnface;

Pen.Color:=clbtnface;

CopyMode:=cmSrcAnd;

StretchDraw(Rect(0,0,16,16), Icn);

end;

end;

end;

procedureTForm1.FormShow(Sender: TObject);

var

ItemInfo: TMenuItemInfo;

hBmp1 : THandle;

begin

HBmp1:=MnuItm.Handle;

withItemInfo 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.

Здравствуйте Валентин!

Заказчик моего проекта обратился с просьбой — "Сделать прогресс индикатор как в приложениях Нортона. Чтоб был в статус строке и НИКАКИХ рамок". ProgressBar в StatusBar — нет проблем, но как быть с рамкой от ProgressBar? ProgressBar всегда вычерчивает рамку и не имеет методов ее управления. Однако появилась интересная идея, воплотившаяся в компонент с новым свойством ShowFrame. Решение оказалось на удивление простым.

unitSProgress;

interface

usesWindows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls;

typeTVSProgressBar = class(TProgressBar)

procedureWMNCPAINT( varMsg: TMessage); messageWM_NCPAINT;

private

{ Private declarations }

FShowFrame: boolean;

procedureSetShowFrame(Value: boolean);

protected

{ Protected declarations }

public

{ Public declarations }

constructorCreate(AOwner: TComponent); override;

published

{ Published declarations }

propertyAlign;

propertyAnchors;

propertyBorderWidth;

propertyDragCursor;

propertyDragKind;

propertyDragMode;

propertyEnabled;

propertyHint;