Читать онлайн «Советы по Delphi. Версия 1.4.3 от 1.1.2001». Страница 82

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;

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.

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

Заказчик моего проекта обратился с просьбой — "Сделать прогресс индикатор как в приложениях Нортона. Чтоб был в статус строке и НИКАКИХ рамок". 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);