Home | Chi sono | Contattami
 

Progr. lineare

Delphi
 
Componenti
  Database
 
Miei articoli

Windows

Miei articoli 

 

Icona nella TrayBar


Questo componente il primo componente Delphi in assoluto che mi sono creato. Era un 12 Luglio afosissimo del 2001 ed alle 7:45 del mattino appena sveglio mi sono detto: ho bisogno di avere una icona nella TrayBar (di fianco all' orologio tanto per parlare in Italiano) da associare ad alcuni miei programmi ed anche ora che imparo a creare dei componenti. Alle 9:15 di sera questo era il risultato, se serve a qualcuno ...

unit TrayIcon; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ShellAPI, extctrls, Menus; const WM_SYSTEM_TRAY_NOTIFY = WM_USER + 1; type TTrayIconMessage =(imClick, imDoubleClick, imMouseDown, imMouseUp, imLeftClickUp, imLeftDoubleClick, imRightClickUp, imRightDoubleClick, imNone); type TTrayIcon = class(TComponent) private { Private declarations } FData: TNotifyIconData; FIsClicked: Boolean; FIcon: TIcon; FIconList: TImageList; FPopupMenu: TPopupMenu; FTimer: TTimer; FHint: string; FIconIndex: integer; FVisible: Boolean; FHide: Boolean; FAnimate: Boolean; FAppRestore: TTrayIconMessage; FPopupMenuShow: TTrayIconMessage; FApplicationHook: TWindowHook; FOnMinimize: TNotifyEvent; FOnRestore: TNotifyEvent; FOnMouseMove: TMouseMoveEvent; FOnMouseExit: TMouseMoveEvent; FOnMouseEnter: TMouseMoveEvent; FOnClick: TNotifyEvent; FOnDblClick: TNotifyEvent; FOnMouseDown: TMouseEvent; FOnMouseUp: TMouseEvent; FOnAnimate: TNotifyEvent; FOnCreate: TNotifyEvent; FOnDestroy: TNotifyEvent; FOnActivate: TNotifyEvent; FOnDeactivate: TNotifyEvent; procedure SetHint(Hint: string); procedure SetHide(Value: Boolean); function GetAnimateInterval: integer; procedure SetAnimateInterval(Value: integer); function GetAnimate: Boolean; procedure SetAnimate(Value: Boolean); procedure EndSession; function ShiftState: TShiftState; protected { Protected declarations } procedure SetVisible(Value: Boolean); virtual; procedure DoMessage(var Message: TMessage);virtual; procedure DoClick; virtual; procedure DoDblClick; virtual; procedure DoMouseMove(Shift: TShiftState; X: integer; Y: integer); virtual; procedure DoMouseDown(Button: TMouseButton; Shift: TShiftState; X: integer; Y: integer); virtual; procedure DoMouseUp(Button: TMouseButton; Shift: TShiftState; X: integer; Y: integer); virtual; procedure DoOnAnimate(Sender: TObject); virtual; procedure Notification(AComponent: TComponent; Operation: TOperation); override; function ApplicationHookProc(var Message: TMessage): Boolean; procedure Loaded(); override; property Data: TNotifyIconData read FData; public { Public declarations } constructor Create(Owner: TComponent); override; destructor Destroy; override; procedure Minimize(); virtual; procedure Restore(); virtual; procedure Update(); virtual; procedure ShowMenu(); virtual; procedure SetIconIndex(Value: integer); virtual; procedure SetDefaultIcon(); virtual; function GetHandle():HWND; published { Published declarations } property Visible: Boolean read FVisible write SetVisible default false; property Hint: string read FHint write SetHint; property PopupMenu: TPopupMenu read FPopupMenu write FPopupMenu; property Hide: Boolean read FHide write SetHide; property RestoreOn: TTrayIconMessage read FAppRestore write FAppRestore; property PopupMenuOn: TTrayIconMessage read FPopupMenuShow write FPopupMenuShow; property Icons: TImageList read FIconList write FIconList; property IconIndex: integer read FIconIndex write SetIconIndex default 0; property AnimateInterval: integer read GetAnimateInterval write SetAnimateInterval default 1000; property Animate: Boolean read GetAnimate write SetAnimate default false; property Handle: HWND read GetHandle; // Events property OnMinimize: TNotifyEvent read FOnMinimize write FOnMinimize; property OnRestore: TNotifyEvent read FOnRestore write FOnRestore; property OnClick: TNotifyEvent read FOnClick write FOnClick; property OnMouseEnter: TMouseMoveEvent read FOnMouseEnter write FOnMouseEnter; property OnMouseExit: TMouseMoveEvent read FOnMouseExit write FOnMouseExit; property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove; property OnMouseUp:TMouseEvent read FOnMouseUp write FOnMouseUp; property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown; property OnAnimate: TNotifyEvent read FOnAnimate write FOnAnimate; property OnCreate: TNotifyEvent read FOnCreate write FOnCreate; property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy; property OnActivate: TNotifyEvent read FOnActivate write FOnActivate; property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate; end; procedure Register; implementation procedure Register; begin RegisterComponents('Carlo Pasolini', [TTrayIcon]); end; constructor TTrayIcon.Create(Owner: TComponent); begin inherited; FIcon := TIcon.Create(); FTimer := TTimer.Create(nil); FIconIndex := 0; FIcon.Assign(Application.Icon); FAppRestore := imDoubleClick; FOnAnimate := DoOnAnimate; FPopupMenuShow := imNone; FVisible := false; FHide := true; FTimer.Enabled := false; FTimer.OnTimer := OnAnimate; FTimer.Interval := 1000; if not (csDesigning in ComponentState) then begin FillChar(FData, sizeof(TNotifyIconData), #0); FData.cbSize := sizeof(TNotifyIconData); FData.Wnd := AllocateHWnd(DoMessage); FData.uID := UINT(Self); FData.hIcon := FIcon.Handle; FData.uFlags := NIF_ICON or NIF_MESSAGE; FData.uCallbackMessage := WM_SYSTEM_TRAY_NOTIFY; FApplicationHook := ApplicationHookProc; Update; end; end; //--------------------------------------------------------------------------- destructor TTrayIcon.Destroy(); begin if not (csDesigning in ComponentState) then begin Shell_NotifyIcon(NIM_DELETE, @FData); //booh forse @FData DeallocateHWnd(FData.Wnd); end; if (Assigned(FIcon)) then FIcon.Free; if (Assigned(FTimer)) then FTimer.Free; inherited; end; //--------------------------------------------------------------------------- procedure TTrayIcon.Notification(AComponent: TComponent; Operation: TOperation); begin inherited Notification(AComponent, Operation); if Operation = opRemove then begin if (AComponent = FIconList) then FIconList := nil else if (AComponent = FPopupMenu) then FPopupMenu := nil; end; end; //--------------------------------------------------------------------------- procedure TTrayIcon.Loaded(); begin inherited Loaded(); if (not Assigned(FIconList)) then begin FAnimate := false; FIcon.Assign(Application.Icon); end else begin FTimer.Enabled := FAnimate; FIconList.GetIcon(FIconIndex, FIcon); end; Update(); end; //--------------------------------------------------------------------------- procedure TTrayIcon.SetVisible(Value: Boolean); begin FVisible := Value; if not (csDesigning in ComponentState) then begin if FVisible then begin if (not Shell_NotifyIcon(NIM_ADD, @FData)) then raise EOutOfResources.Create('Cannot Create System Shell Notification Icon'); Hide := true; Application.HookMainWindow(FApplicationHook); end else begin if (not Shell_NotifyIcon(NIM_DELETE, @FData)) then raise EOutOfResources.Create('Cannot Remove System Shell Notification Icon'); Hide := false; Application.UnhookMainWindow(FApplicationHook); end; end; end; //--------------------------------------------------------------------------- procedure TTrayIcon.SetHint(Hint: string); begin // The new hint must be different than the previous hint and less than // 64 characters to be modified. 64 is an operating system limit. if ((FHint <> Hint) and (Length(Hint) < 64)) then begin FHint := Hint; StrPLCopy(FData.szTip, Hint, sizeof(FData.szTip) - 1); // If there is no hint then there is no tool tip. if (Length(Hint) <> 0) then FData.uFlags := FData.uFlags or NIF_TIP else FData.uFlags := FData.uFlags and (not NIF_TIP); Update(); end; end; //--------------------------------------------------------------------------- procedure TTrayIcon.SetHide(Value: Boolean); begin FHide := Value; end; //--------------------------------------------------------------------------- function TTrayIcon.GetAnimateInterval(): integer; begin Result := FTimer.Interval; end; //--------------------------------------------------------------------------- procedure TTrayIcon.SetAnimateInterval(Value: integer); begin FTimer.Interval := Value; end; //--------------------------------------------------------------------------- function TTrayIcon.GetAnimate(): Boolean; begin Result := FAnimate; end; //--------------------------------------------------------------------------- procedure TTrayIcon.SetAnimate(Value: Boolean); begin if (Assigned(FIconList) or (csLoading in ComponentState)) then FAnimate := Value; if (Assigned(FIconList) and (not (csDesigning in ComponentState))) then FTimer.Enabled := Value; end; //--------------------------------------------------------------------------- procedure TTrayIcon.EndSession(); begin Shell_NotifyIcon(NIM_DELETE, @FData); end; //--------------------------------------------------------------------------- function TTrayIcon.ShiftState(): TShiftState; var Res: TShiftState; begin Res := []; if (GetKeyState(VK_SHIFT) < 0) then Res := Res + [ssShift]; if (GetKeyState(VK_CONTROL) < 0) then Res := Res + [ssCtrl]; if (GetKeyState(VK_MENU) < 0) then Res := Res + [ssAlt]; Result := Res; end; //--------------------------------------------------------------------------- procedure TTrayIcon.DoMessage(var Message: TMessage); var point: TPoint; shift: TShiftState; begin case (Message.Msg) of WM_QUERYENDSESSION: Message.Result := 1; WM_ENDSESSION: EndSession(); WM_SYSTEM_TRAY_NOTIFY: case (Message.LParam) of WM_MOUSEMOVE: if (Assigned(FOnClick)) then begin shift := ShiftState(); GetCursorPos(point); DoMouseMove(shift, point.x, point.y); end; WM_LBUTTONDOWN: begin shift := ShiftState(); shift := shift + [ssLeft]; GetCursorPos(point); DoMouseDown(mbLeft, shift, point.x, point.y); FIsClicked := true; end; WM_LBUTTONUP: begin shift := ShiftState(); shift := shift + [ssLeft]; GetCursorPos(point); if (Assigned(FOnClick)) then DoClick(); DoMouseUp(mbLeft, shift, point.x, point.y); if (FAppRestore = imLeftClickUp) then Restore(); if (FPopupMenuShow = imLeftClickUp) then ShowMenu(); end; WM_LBUTTONDBLCLK: begin DoDblClick(); if (FAppRestore = imLeftDoubleClick) then Restore(); if (FPopupMenuShow = imLeftDoubleClick) then ShowMenu(); end; WM_RBUTTONDOWN: begin shift := ShiftState(); shift := shift + [ssRight]; GetCursorPos(point); DoMouseDown(mbRight, shift, point.x, point.y); end; WM_RBUTTONUP: begin shift := ShiftState(); shift := shift + [ssRight]; GetCursorPos(point); DoMouseUp(mbRight, shift, point.x, point.y); if (FAppRestore = imRightClickUp) then Restore(); if (FPopupMenuShow = imRightClickUp) then ShowMenu(); end; WM_RBUTTONDBLCLK: begin DoDblClick(); if (FAppRestore = imRightDoubleClick) then Restore(); if (FPopupMenuShow = imRightDoubleClick) then ShowMenu(); end; WM_MBUTTONDOWN: begin shift := ShiftState(); shift := shift + [ssMiddle]; GetCursorPos(point); DoMouseDown(mbMiddle, shift, point.x, point.y); end; WM_MBUTTONUP: begin shift := ShiftState(); shift := shift + [ssMiddle]; GetCursorPos(point); DoMouseUp(mbMiddle, shift, point.x, point.y); end; WM_MBUTTONDBLCLK: DoDblClick(); end; //end case end; //end case inherited Dispatch(Message); end; //--------------------------------------------------------------------------- procedure TTrayIcon.ShowMenu(); var point: TPoint; begin GetCursorPos(point); if (Screen.ActiveForm.Handle <> 0) then SetForegroundWindow(Screen.ActiveForm.Handle); FPopupMenu.Popup(point.x, point.y); end; //--------------------------------------------------------------------------- procedure TTrayIcon.DoClick(); begin if (FAppRestore = imClick) then Restore(); if (FPopupMenuShow = imClick) then ShowMenu(); if (Assigned(FOnClick)) then FOnClick(Self); end; //--------------------------------------------------------------------------- procedure TTrayIcon.DoDblClick(); begin if (FAppRestore = imDoubleClick) then Restore(); if (FPopupMenuShow = imDoubleClick) then ShowMenu(); if (Assigned(FOnDblClick)) then FOnDblClick(Self); end; //--------------------------------------------------------------------------- procedure TTrayIcon.DoMouseMove(Shift: TShiftState; X:integer; Y: integer); begin if (Assigned(FOnMouseMove)) then FOnMouseMove(Self, Shift, X, Y); end; //--------------------------------------------------------------------------- procedure TTrayIcon.DoMouseDown(Button: TMouseButton; Shift: TShiftState; X: integer; Y: integer); begin if (FAppRestore = imMouseDown) then Restore(); if (FPopupMenuShow = imMouseDown) then ShowMenu(); if (Assigned(FOnMouseDown)) then FOnMouseDown(Self, Button, Shift, X, Y); end; //--------------------------------------------------------------------------- procedure TTrayIcon.DoMouseUp(Button: TMouseButton; Shift: TShiftState; X: integer; Y:integer); begin if (FAppRestore = imMouseDown) then Restore(); if (FPopupMenuShow = imMouseDown) then ShowMenu(); if (Assigned(FOnMouseUp)) then FOnMouseUp(Self, Button, Shift, X, Y); end; //--------------------------------------------------------------------------- procedure TTrayIcon.DoOnAnimate(Sender: TObject); begin if (IconIndex < FIconList.Count) then Inc(FIconIndex) else FIconIndex := 0; SetIconIndex(FIconIndex); Update(); end; //--------------------------------------------------------------------------- procedure TTrayIcon.Minimize(); begin Application.Minimize(); ShowWindow(Application.Handle, SW_HIDE); if (Assigned(FOnMinimize)) then FOnMinimize(Self); end; //--------------------------------------------------------------------------- procedure TTrayIcon.Restore(); begin Application.Restore(); ShowWindow(Application.Handle, SW_RESTORE); SetForegroundWindow(Application.Handle); if (Assigned(FOnRestore)) then FOnRestore(Self); end; //--------------------------------------------------------------------------- procedure TTrayIcon.Update(); begin if not (csDesigning in ComponentState) then begin FData.hIcon := FIcon.Handle; if (Visible = true) then Shell_NotifyIcon(NIM_MODIFY, @FData); end; end; //--------------------------------------------------------------------------- procedure TTrayIcon.SetIconIndex(Value: integer); begin FIconIndex := Value; if (Assigned(FIconList)) then FIconList.GetIcon(FIconIndex, FIcon); Update(); end; //--------------------------------------------------------------------------- function TTrayIcon.ApplicationHookProc(var Message: TMessage): Boolean; begin if (Message.Msg = WM_SYSCOMMAND) then begin if (Message.WParam = SC_MINIMIZE) then Minimize(); if (Message.WParam = SC_RESTORE) then Restore(); end; Result:= false; end; //--------------------------------------------------------------------------- procedure TTrayIcon.SetDefaultIcon(); begin FIcon.Assign(Application.Icon); Update(); end; //--------------------------------------------------------------------------- function TTrayIcon.GetHandle(): HWND; begin Result := FData.Wnd; end; //--------------------------------------------------------------------------- end.

 

 
 
Your Ad Here