msystray.pas

dephi的提醒源码

unit MSysTray;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, Menus, ShellAPI;

{$IFDEF VER140}
{$DEFINE D6}
{$ENDIF}

{$IFDEF VER150}
{$DEFINE D6}
{$DEFINE D7}
{$ENDIF}

(* TMTrayIcon *)

Const
	WM_TRAYICON   = WM_USER + 1128;
    WM_TRAYMENU   = WM_USER + 1129;

Type

  TMTrayIcon = class(TComponent)
  private
    { Private declarations }
    FClickStart  : Boolean;

    Procedure IconChange( aSender : TObject ); 
    procedure ModifyIcon( aOp : Cardinal = NIM_MODIFY );

    Procedure SetIcon( aIcon : TIcon );
    Procedure SetHint( aHint : String );
    Procedure SetShowHint( aShowHint : Boolean );
    Procedure SetVisible( aVisible : Boolean );
  protected
    { Protected declarations }
    FNID   : TNOTIFYICONDATA;
    FIcon  : TIcon;

    FHint          : String;
    FPopupMenu     : TPopupMenu;
    FShowHint      : Boolean;
    FVisible       : Boolean;

    //  Events
    FOnClick     : TNotifyEvent;
    FOnDblClick  : TNotifyEvent;
    FOnMouseDown : TMouseEvent;
    FOnMouseMove : TMouseMoveEvent;
    FOnMouseUp   : TMouseEvent;

    Procedure TrayIconMessage( Var Message : TMessage ); Virtual;
    Procedure Loaded; override;
	Procedure Notification( aComponent : TComponent; aOperation : TOperation ); override;
  public
    { Public declarations }
    Constructor Create( aOwner : TComponent ); override;
    Destructor  Destroy; override;

    Procedure ShowForm( aShow : Boolean );
  published
    { Published declarations }
    property Hint        : String     read FHint        write SetHint;
    property Icon        : TIcon      read FIcon        write SetIcon;
    property PopupMenu   : TPopupMenu read FPopupMenu   write FPopupMenu;
    property ShowHint    : Boolean    read FShowHint    write SetShowHint  default false;
    property Visible     : Boolean    read FVisible     write SetVisible   default true;
    //  Events
    property OnClick     : TNotifyEvent    read FOnClick     write FOnClick;
    property OnDblClick  : TNotifyEvent    read FOnDblClick  write FOnDblClick;
    property OnMouseDown : TMouseEvent     read FOnMouseDown write FOnMouseDown;
    property OnMouseMove : TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
    property OnMouseUp   : TMouseEvent     read FOnMouseUp   write FOnMouseUp;
  end;

procedure Register;

implementation

(* TMTrayIcon *)

Constructor TMTrayIcon.Create( aOwner : TComponent );
Begin
	Inherited Create( aOwner );

	FClickStart := false;

    FIcon       := TIcon.Create;
    FIcon.OnChange := IconChange;
    FHint       := '';
    FPopupMenu  := Nil;
    FShowHint   := false;
    FVisible    := true;

	FillMemory( @FNID, SizeOf( TNOTIFYICONDATA ), 0 );
	With FNID Do
   	Begin
       	cbSize := SizeOf( TNOTIFYICONDATA );
        {$IFDEF D6}
        Wnd    := Classes.AllocateHWnd( TrayIconMessage );
        {$ELSE}
   		Wnd    := AllocateHwnd( TrayIconMessage );
        {$ENDIF}
    	uID    := Cardinal( Self );
	    uFlags := NIF_ICON OR NIF_MESSAGE OR NIF_TIP;
    	uCallBackMessage := WM_TRAYICON;
   	End;
	If ( Not ( csDesigning in ComponentState ) ) Then
	Begin  // On runtime
	    FHint      := Application.Title;
        FNID.hIcon := Application.Icon.Handle;
    End;
End;

Destructor TMTrayIcon.Destroy;
Begin
    ModifyIcon( NIM_DELETE );  //  Only run time
    {$IFDEF D6}
   	Classes.DeallocateHwnd( FNID.Wnd );
    {$ELSE}
   	DeallocateHwnd( FNID.Wnd );
    {$ENDIF}
    If ( Not FIcon.Empty ) Then
	    FIcon.ReleaseHandle;
    FIcon.Free;
    Inherited Destroy;
End;

Procedure TMTrayIcon.Loaded;
Begin
	Inherited Loaded;
    ModifyIcon( NIM_ADD );  //  Only run time
End;

Procedure TMTrayIcon.Notification( aComponent : TComponent;
	aOperation : TOperation );
Begin
	Inherited Notification( aComponent, aOperation );
    //  Check if either the imagelist or the popup menu is about to be deleted
    If ( aComponent = PopupMenu ) AND ( aOperation = opRemove ) Then
        PopupMenu := Nil;
End;

Procedure TMTrayIcon.TrayIconMessage( Var Message : TMessage );

	Function ShiftState : TShiftState;
    Begin
    	Result := [];
        If ( GetKeyState( VK_SHIFT ) < 0 ) Then
        	Include( Result, ssShift );
        If ( GetKeyState( VK_CONTROL ) < 0 ) Then
        	Include( Result, ssCtrl );
        If ( GetKeyState( VK_MENU ) < 0 ) Then
        	Include( Result, ssAlt );
    End;

var
    Pt : TPoint;
    Shift : TShiftState;
    i : Integer;
Begin
	If ( Message.Msg = WM_TRAYICON ) Then
    Begin
		GetCursorPos( Pt );
    	Case Message.lParam Of
        WM_MOUSEMOVE :
        	If Assigned( FOnMouseMove ) Then
            	FOnMouseMove( Self, ShiftState, Pt.x, Pt.y );
        WM_LBUTTONDOWN :
        	Begin
        		If Assigned( FOnMouseDown ) Then
	            Begin
    	        	Shift := ShiftState + [ssLeft];
        	        FOnMouseDown( Self, mbLeft, Shift, Pt.x, Pt.y );
            	End;
				FClickStart := true;
    	    End;
        WM_RBUTTONDOWN :
        	Begin
        		If Assigned( FOnMouseDown ) Then
	            Begin
    	        	Shift := ShiftState + [ssRight];
        	        FOnMouseDown( Self, mbRight, Shift, Pt.x, Pt.y );
	        	End;
                If ( Assigned( FPopupMenu ) ) Then
					PostMessage( FNID.Wnd, WM_TRAYMENU, 0, Pt.x + ( pt.y SHL 16 ) );
(*                Begin
                    SetForegroundWindow( FNID.Wnd );
                    FPopupMenu.PopupComponent := Self;
                    With Message Do
                        FPopupMenu.Popup( Pt.x, Pt.y );
                    PostMessage( FNID.Wnd, WM_NULL, 0, 0 );
                End;
*)
//				PostMessage( ( Owner As TWinControl ).Handle, WM_TRAYMENU, 0, Pt.x + ( pt.y SHL 16 ) );
        	End;
    	WM_LBUTTONUP :
	        Begin
    	        If FClickStart Then
        	    Begin
            		FClickStart := false;
                	If Assigned( FOnClick ) Then
                		FOnClick( Self );
	            End;
    	    	If Assigned( FOnMouseUp ) Then
        	    Begin
	        	   	Shift := ShiftState + [ssLeft];
	                FOnMouseUp( Self, mbLeft, Shift, Pt.x, Pt.y );
    	        End;
        	End;
        WM_RBUTTONUP :
        	If Assigned( FOnMouseUp ) Then
            Begin
            	Shift := ShiftState + [ssRight];
                FOnMouseUp( Self, mbRight, Shift, Pt.x, Pt.y );
            End;
        WM_LBUTTONDBLCLK :
	        Begin
            	SetForegroundWindow( FNID.Wnd );
    	    	If Assigned( FOnDblClick ) Then
        	    	FOnDblClick( Self )
                Else If Assigned( FPopupMenu ) Then
	            Begin
    	        	i := FPopupMenu.Items.Count - 1;
        	        While ( i >= 0 ) AND ( Not FPopupMenu.Items[i].Default ) Do
            	    	Dec( i );
    	        	If ( i >= 0 ) Then
	            		FPopupMenu.Items[i].Click;  //  Do default menu item
	            End;
    	    End;
        End;
    End
    Else If ( Message.Msg = WM_TRAYMENU ) Then
    Begin
    	SetForegroundWindow( FNID.Wnd );
    	FPopupMenu.PopupComponent := Self;
        With Message Do
        	FPopupMenu.Popup( LParamLo, LParamHi );
        PostMessage( FNID.Wnd, WM_NULL, 0, 0 );
    End
      { Evaluate WM_QUERYENDSESSION message to tell Windows that the
        icon will stop executing if user requests a shutdown (Msg.Result
        must not return 0, or the system will not be able to shut down). }
    Else If ( Message.Msg = WM_QUERYENDSESSION ) Then
		Message.Result := 1
    Else If ( Message.Msg = WM_ENDSESSION ) Then
    	ModifyIcon( NIM_DELETE )
    Else
    	Message.Result := DefWindowProc( FNID.Wnd, Message.Msg, Message.wParam, Message.lParam );
End;
(*
Procedure TMTrayIcon.HookAppMessage(  Var Message : TMessage );
Begin
	Case Message.Msg Of
    WM_SIZE :
    	If ( Message.wParam = SIZE_MINIMIZED ) Then
        Begin
        	If FMinToTray Then
            	ShowForm( false );
        End;
    End;
    Message.Result := CallWindowProc( FOldAppMessage, Application.Handle,
    	Message.Msg, Message.wParam, Message.lParam );
End;

Procedure TMTrayIcon.HookWinMessage( Var Message : TMessage );
Begin
	Case Message.Msg Of
    WM_SHOWWINDOW :
    	If ( Message.lParam = 0 ) AND ( Message.wParam = 1 ) Then
        	ShowForm( true );
    WM_WINDOWPOSCHANGED :
    	If Assigned( Screen.ActiveControl ) Then
        	SetFocus( Screen.ActiveControl.Handle );
    WM_TRAYMENU :
    	If Assigned( FPopupMenu ) Then
        Begin
	    	SetForegroundWindow( ( Owner As TWinControl ).Handle );
		    With Message Do
            Begin
            	FPopupMenu.PopupComponent := Self;
    			FPopupMenu.Popup( LParamLo, LParamHi );
            End;
        End;
    WM_SYSCOMMAND :
    	If FCloseToTray AND ( Message.wParam = SC_CLOSE ) Then
        	Message.wParam := SC_MINIMIZE;
    End;
    Message.Result := CallWindowProc( FOldWinMessage, ( Owner As TWinControl ).Handle,
    	Message.Msg, Message.wParam, Message.lParam);
End;

procedure TMTrayIcon.ShowForm( aShow : Boolean );
Begin
	If aShow Then
	Begin
	    SetForegroundWindow( ( Owner As TWinControl ).Handle );
        ( Owner As TWinControl ).Visible := true;
        ShowWindow( Application.Handle, SW_RESTORE );
    End
    Else
    Begin
    	( Owner As TWinControl ).Visible := false;
        ShowWindow( Application.Handle, SW_HIDE );
    End;
End;
*)
Procedure TMTrayIcon.ShowForm( aShow : Boolean );
Begin
	If ( ( Owner Is TForm ) AND ( aShow <> ( Owner As TForm ).Visible ) ) Then
    Begin
    	If ( aShow ) Then
        Begin
        	( Owner As TForm ).Visible := true;
            ShowWindow( Application.Handle, SW_RESTORE );
            ( Owner As TForm ).WindowState := wsNormal;
            Application.Restore;
            SetForegroundWindow( ( Owner As TForm ).Handle );
        End
        Else
        Begin
        	Application.Minimize;
            ShowWindow( Application.Handle, SW_HIDE );
        	( Owner As TForm ).Visible := false;
        End;
    End;
End;

Procedure TMTrayIcon.IconChange( aSender : TObject );
Begin
	FNID.hIcon := FIcon.Handle;
	ModifyIcon;
End; 

procedure TMTrayIcon.ModifyIcon( aOp : Cardinal );
Begin
	If ( Not ( csDesigning in ComponentState ) ) Then
    	Shell_NotifyIcon( aOp, @FNID );
End;

//  Properties

Procedure TMTrayIcon.SetHint( aHint : String );
Begin
	If ( aHint <> FHint ) Then
    Begin
    	FHint := aHint;
		StrLCopy( FNID.szTip, PChar( FHint ), 63 );
        ModifyIcon;
	End;
End;

Procedure TMTrayIcon.SetShowHint( aShowHint : Boolean );
Begin
	If ( aShowHint <> FShowHint ) Then
    Begin
    	FShowHint := aShowHint;
        If ( FShowHint ) Then
        Begin
        	StrLCopy( FNID.szTip, PChar( FHint ), 63 );
    	    FNID.uFlags := NIF_ICON OR NIF_MESSAGE OR NIF_TIP;
        End
        Else
        Begin
        	FNID.szTip[0] := #0;
    	    FNID.uFlags := NIF_ICON OR NIF_MESSAGE;
        End;
        ModifyIcon;
    End;
End;

Procedure TMTrayIcon.SetIcon( aIcon : TIcon );
Begin
	If ( aIcon <> FIcon ) Then
    Begin
   		If ( Not FIcon.Empty ) Then
        	FIcon.ReleaseHandle;
    	FIcon.Assign( aIcon );  //  Auto call event IconChange
    End;
End;

Procedure TMTrayIcon.SetVisible( aVisible : Boolean );
Begin
	If ( aVisible <> FVisible ) Then
    Begin
    	FVisible := aVisible;
    	If FVisible Then
        	ModifyIcon( NIM_ADD )
        Else
        	ModifyIcon( NIM_DELETE );
    End;
End;

procedure Register;
begin
  RegisterComponents( 'MentalCtrls', [TMTrayIcon] );
end;

end.