Валентин Озеров - Советы по Delphi. Версия 1.4.3 от 1.1.2001
procedureTfrmExplorer.TreeViewMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var P : TPoint;
begin
if Button<>mbRight then exit;
TreeMenu.AutoPopup := False;
if TreeView.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;
Иконки в PopupMenu
Delphi 2
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:win95systemshell32.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.
ProgressBar
ProgressBar — невидимка
Письмо читателя
Здравствуйте Валентин!
Заказчик моего проекта обратился с просьбой — "Сделать прогресс индикатор как в приложениях Нортона. Чтоб был в статус строке и НИКАКИХ рамок". ProgressBar в StatusBar — нет проблем, но как быть с рамкой от ProgressBar? ProgressBar всегда вычерчивает рамку и не имеет методов ее управления. Однако появилась интересная идея, воплотившаяся в компонент с новым свойством ShowFrame. Решение оказалось на удивление простым.
unit SProgress;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls;
type TVSProgressBar = class(TProgressBar)
procedure WMNCPAINT(var Msg: TMessage); message WM_NCPAINT;
private
{ Private declarations }
FShowFrame: boolean;
procedure SetShowFrame(Value: boolean);
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
published
{ Published declarations }
property Align;
property Anchors;
property BorderWidth;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Hint;
property Constraints;
property Min;
property Max;
property Orientation;
property ParentShowHint;
property PopupMenu;
property Position;
property ShowFrame: boolean read FShowFrame write SetShowFrame;
property ShowHint;
property Smooth;
property Step;
property TabOrder;
property TabStop;
property Visible;
property OnContextPopup;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
end;
procedure Register;
implementation
{ TVSProgressBar }
constructor TVSProgressBar.Create(AOwner: TComponent);
begin
Inherited;
FShowFrame:= True;
end;
procedure TVSProgressBar.SetShowFrame(Value: boolean);
