//*******************************************************
//
//    Copyright © 1995-2002 by Lucian Radulescu
//    mailto  :  lucian@ez-delphi.com
//    http    :  http://www.ez-delphi.com
//
//*******************************************************

unit SingleInst;

interface

uses
Windows, Messages, ShellAPI, SysUtils, Classes, Forms, AppEvnts;

const
WM_ICONMESSAGE      = WM_USER;

type

TOnTrayIconRClick = procedure( Sender: TObject; P: TPoint ) of object;

// TSingleInstance
TSingleInstance = class( TApplicationEvents )
private
{ Private declarations }
FRef             : Integer;            // reference count, this is a singleton
FMutex           : THandle;            // mutex handle, single instance application
Owned            : Boolean;            // flag if we own the mutex
FInstanceName    : String;             // Owner (form) class name, used to set mutex
FHandle          : HWND;               // internal window handle
FInitDone        : Boolean;

    FDisableSysCloseInTray : Boolean;      // enable/disable Close Application when in tray
FHideOnMinWhenInTray   : Boolean;      // Hide Application on minimize when in tray
FHideOnCloseWhenInTray : Boolean;      // Hide Application on close when in tray
FRunInTray       : Boolean;            // enable/disable run in tray
FStartInTray     : Boolean;            // enable/disable start in tray
FTrayIconLDblClk : TNotifyEvent;       // trayicon double click event
FTrayIconRClk    : TOnTrayIconRClick;  // trayicon right click event

FUserOnMinimize  : TNotifyEvent;       // initial AppEvent.OnMinimize
FUserOnRestore   : TNotifyEvent;       // initial AppEvent.Restore

function  CheckPrevInstance: Boolean;
procedure SetDisableSysCloseInTray( Value: Boolean );
procedure SetHideOnMinInTray( Value: Boolean );
procedure SetHideOnCloseInTray( Value: Boolean );
procedure SetRunInTray( Value: Boolean );
procedure SetStartInTray( Value: Boolean );
protected
{ Protected declarations }
procedure DoTrayLBtnDblClick;
procedure DoTrayIconRClick( P: TPoint );

procedure AppOnMinimize( Sender : TObject );
procedure AppOnRestore( Sender : TObject );
procedure Loaded; override;
procedure WndProc( var Msg: TMessage );

public
{ Public declarations }
class function NewInstance: TObject; override;
procedure FreeInstance; override;

constructor Create( AOwner: TComponent ); override;
destructor Destroy; override;

// when component is created at run time, Loaded is not called
// the user MUST call Initialize.
procedure Initialize;

procedure MainFormClose( Sender: TObject; var Action: TCloseAction );
procedure UseTray; overload;
procedure UseTray( nidType: DWORD ); overload;
procedure UseTray( Icon: THandle; Tip: PChar; nidType: DWORD = NIM_MODIFY ); overload;
published
{ Published declarations }
property RunInTray: Boolean read FRunInTray write SetRunInTray default FALSE;
property StartInTray: Boolean read FStartInTray write SetStartInTray default FALSE;
property DisableSysCloseInTray: Boolean read FDisableSysCloseInTray write SetDisableSysCloseInTray default FALSE;
property HideOnMinWhenInTray: Boolean read FHideOnMinWhenInTray write SetHideOnMinInTray default FALSE;
property HideOnCloseWhenInTray: Boolean read FHideOnCloseWhenInTray write SetHideOnCloseInTray default FALSE;
property OnActionExecute;
property OnActionUpdate;
property OnActivate;
property OnDeactivate;
property OnException;
property OnIdle;
property OnHelp;
property OnHint;
property OnMessage;
property OnMinimize;
property OnRestore;
property OnShowHint;
property OnShortCut;
property OnSettingChange;
property OnTrayLBtnDblClick: TNotifyEvent Read FTrayIconLDblClk write FTrayIconLDblClk;
property OnTrayIconRClick: TOnTrayIconRClick read FTrayIconRClk write FTrayIconRClk;
end;

procedure Register;

implementation

{$R *.dcr}

const
DW_SHOW_FLAG = SWP_NOSIZE + SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE;
  uEnable : array [Boolean] of UINT = ( mf_Enabled, mf_Grayed );

var
_SingleInstance: TSingleInstance = nil;

function EnumWindowsProc( W: HWND; L: Longint ): Boolean; stdcall;
var
CName : array [0..255] of Char;
  Owner : HWnd;
begin

// retrieves the name of the class to which "W" belongs.
GetClassName( W, CName, SizeOf(CName) );

// retrieve the Owner of "W"
Owner := GetWindow( W, GW_OWNER );

// stop enumeration (set result to false) if we found previous window
Result := not ( ( StrIComp( PChar(L), CName ) = 0 ) and // classname match
( Application.Handle <> Owner ) );      // Owner is not our App

// did we find it?
if not Result then
begin
if IsIconic( Owner ) then
SendMessage( Owner, WM_SYSCOMMAND, SC_RESTORE, 0 )
else
// if not IsWindowVisible( Owner ) then
ShowWindow( Owner, SW_SHOW );

    SetActiveWindow( Owner );         // activate it
SetForegroundWindow( Owner);      // bring it to foreground
end;
end;

// check for existance of a previous instance. return true if we are the
// first instance and we acquired the ownership of the mutex
function TSingleInstance.CheckPrevInstance: Boolean;
var
CName  : array [0..255] of Char;
begin

// we won't get ownership if ERROR_ALREADY_EXISTS
Owned  := FALSE;

// create the mutex, requesting ownership
FMutex := CreateMutex( nil, TRUE, PChar(Application.Title) );

// return true if createmutex succeeded and if we are the first instance
Result := ( FMutex <> 0 ) and ( GetLastError <> ERROR_ALREADY_EXISTS );

// did we fail?
if not Result then
begin
// initialize
FillChar( CName, SizeOf(CName), #0 );
    StrPCopy( CName, FInstanceName );
// go after the previous instance
EnumWindows ( @EnumWindowsProc, Longint(@CName) );
end
else
begin
// make we sure we are the owner of the mutex
WaitForSingleObject( FMutex, 10 );
    Owned := TRUE;
end;
end;

procedure TSingleInstance.SetDisableSysCloseInTray( Value: Boolean );
begin
if FDisableSysCloseInTray <> Value then
begin
if Value and not FRunInTray then Exit;
    FDisableSysCloseInTray := Value;
if not Value then HideOnMinWhenInTray := False;
if csDesigning in ComponentState then Exit;
    EnableMenuItem( GetSystemMenu( Application.Handle, False ), SC_CLOSE,
      uEnable[ FRunInTray and FDisableSysCloseInTray ] );
if Owner <> nil then
EnableMenuItem( GetSystemMenu( TForm(Owner).Handle, False ), SC_CLOSE,
        uEnable[ FRunInTray and FDisableSysCloseInTray ] );
end;
end;

procedure TSingleInstance.SetHideOnMinInTray( Value: Boolean );
begin
if FHideOnMinWhenInTray <> Value then
begin
if Value and not FRunInTray then Exit;
    FHideOnMinWhenInTray := Value;
end;
end;

procedure TSingleInstance.SetHideOnCloseInTray( Value: Boolean );
begin
if FHideOnCloseWhenInTray <> Value then
begin
if Value and not FRunInTray then Exit;
if Value and not FDisableSysCloseInTray then Exit;
    FHideOnCloseWhenInTray := Value;
end;
end;

procedure TSingleInstance.SetRunInTray( Value: Boolean );
begin
if FRunInTray <> Value then
begin
FRunInTray := Value;
if FDisableSysCloseInTray and not Value then
FDisableSysCloseInTray := FALSE;
if FHideOnMinWhenInTray and not Value then
FHideOnMinWhenInTray := FALSE;
if FHideOnCloseWhenInTray and not Value then
FHideOnCloseWhenInTray := FALSE;
    UseTray;
end;
end;

procedure TSingleInstance.SetStartInTray( Value: Boolean );
begin
if FStartInTray <> Value then
begin
if Value and not FRunInTray then Exit;
    FStartInTray := Value;
end;
end;

procedure TSingleInstance.Initialize;
begin
if not (csDesigning in ComponentState) then
begin
if not CheckPrevInstance then
begin
Free;
      Halt;
end;
    FHandle        := AllocateHWnd( WndProc );
    FUserOnMinimize:= OnMinimize;
    FUserOnRestore := OnRestore;
    OnMinimize     := AppOnMinimize;
    OnRestore      := AppOnRestore;
    UseTray;
end;
  FInitDone := TRUE;
end;

constructor TSingleInstance.Create( AOwner: TComponent );
begin
inherited Create( AOwner );
if FRef > 1 then Exit;

  FInstanceName  := Owner.ClassName;
  FDisableSysCloseInTray := FALSE;
  FHideOnMinWhenInTray := FALSE;
  FHideOnCloseWhenInTray := FALSE;
  FRunInTray     := FALSE;
  FStartInTray   := FALSE;
  FUserOnMinimize:= nil;
  FUserOnRestore := nil;
  FInstanceName  := Owner.ClassName;
  FInitDone      := FALSE;
end;

procedure TSingleInstance.Loaded;
begin
inherited Loaded;
  Initialize;
end;

destructor TSingleInstance.Destroy;
begin
if FRef = 1 then
begin
UseTray( NIM_DELETE );
if FHandle <> 0 then
DeallocateHWnd( FHandle );
    FHandle := 0;
end;
inherited Destroy;
end;

procedure TSingleInstance.DoTrayLBtnDblClick;
begin
Application.Restore;
  SetForegroundWindow( Application.Handle );
if Assigned( Application.MainForm ) then
if not Application.MainForm.Visible then
Application.MainForm.Visible := TRUE;
if Assigned( FTrayIconLDblClk ) then
FTrayIconLDblClk( Self );
end;

procedure TSingleInstance.DoTrayIconRClick( P: TPoint );
begin
if Assigned( FTrayIconRClk ) then
FTrayIconRClk( Self, P );
end;

procedure TSingleInstance.AppOnMinimize( Sender : TObject );
begin
if FRunInTray and ( FHideOnMinWhenInTray or FHideOnCloseWhenInTray ) then
begin
SetWindowPos( Application.Handle, 0, 0, 0, 0, 0, DW_SHOW_FLAG + SWP_HIDEWINDOW );
if Assigned( Application.MainForm ) then Application.MainForm.Visible := FALSE;
end;
if Assigned( FUserOnMinimize ) then FUserOnMinimize( Sender );
end;

procedure TSingleInstance.AppOnRestore( Sender : TObject );
begin
if FRunInTray and ( FHideOnMinWhenInTray or FHideOnCloseWhenInTray ) then
begin
SetWindowPos( Application.Handle, 0, 0, 0, 0, 0, DW_SHOW_FLAG + SWP_SHOWWINDOW );
if Assigned( Application.MainForm ) then
Application.MainForm.Visible := TRUE;
end;
if Assigned( FUserOnRestore ) then FUserOnRestore( Sender );
end;

procedure TSingleInstance.WndProc(var Msg: TMessage);
var
P: TPoint;
begin
case Msg.Msg of
WM_QUERYENDSESSION: Msg.Result := 1;
    WM_ICONMESSAGE:
case Msg.lParam of
WM_LBUTTONDBLCLK : DoTrayLBtnDblClick;
         WM_RBUTTONDOWN   : begin
GetCursorPos( P );
                              DoTrayIconRClick( P );
end;
else DefWindowProc( FHandle, Msg.Msg, Msg.wParam, Msg.lParam );
end;
else
DefWindowProc( FHandle, Msg.Msg, Msg.wParam, Msg.lParam );
end;
end;

class function TSingleInstance.NewInstance: TObject;
begin
if _SingleInstance = nil then
begin
Result := inherited NewInstance;
if Result <> nil then
begin
TSingleInstance( Result ).FRef := 1;
     _SingleInstance := TSingleInstance( Result );
end;
end
else
begin
Result := _SingleInstance;
    Inc( TSingleInstance( Result ).FRef );
end;
end;

procedure TSingleInstance.FreeInstance;
begin
Dec( FRef );
if FRef = 0 then
try
// Release the mutex only if *we own* it. If we are the second instance,
// we don't own the mutex, and  the realeasemutex call will fail
// That bothers some debugging tools (Sleuth QA, for exxample).
if ( FMutex <> 0 ) and Owned then ReleaseMutex( FMutex );
finally
if ( FMutex <> 0 ) then CloseHandle( FMutex );
inherited FreeInstance;
    _SingleInstance := nil;
end;
end;

procedure TSingleInstance.MainFormClose( Sender: TObject; var Action: TCloseAction );
begin
if FRunInTray and FDisableSysCloseInTray then
begin
Action := caNone;
if FHideOnCloseWhenInTray then
Application.Minimize;
end
else Action := caFree;
end;

procedure TSingleInstance.UseTray( Icon: THandle; Tip: PChar; nidType: DWORD = NIM_MODIFY );
var
nid: TNotifyIconData;
begin
nid.cbSize := SizeOf( nid );
  nid.Wnd := FHandle;
  nid.uID := 1;
  nid.uCallbackMessage := wm_IconMessage;
  nid.hIcon := Icon;
case nidType of
NIM_ADD    : nid.uFlags := nif_Icon or nif_Tip or nif_message;
    NIM_MODIFY : nid.uFlags := nif_Icon or nif_Tip;
    NIM_DELETE : nid.uFlags := 0;
end;
  StrCopy( nid.szTip, Tip );
  Shell_NotifyIcon( nidType, @nid );
end;

procedure TSingleInstance.UseTray( nidType: DWORD );
begin
UseTray( Application.Icon.Handle, PChar(Application.Title), nidType );
end;

procedure TSingleInstance.UseTray;
const
uID : array [Boolean] of UINT = ( NIM_DELETE, NIM_ADD );
begin
if [csDesigning, csLoading, csDestroying] * ComponentState = [] then
begin
UseTray( uID[FRunInTray] );
if [csDestroying, csDesigning] * ComponentState <> [] then Exit;
    EnableMenuItem( GetSystemMenu( Application.Handle, False ), SC_CLOSE,
      uEnable[ FRunInTray and FDisableSysCloseInTray ] );
if Owner <> nil then
EnableMenuItem( GetSystemMenu( TForm(Owner).Handle, False ), SC_CLOSE,
        uEnable[ FRunInTray and FDisableSysCloseInTray ] );
end;
end;

procedure Register;
begin
RegisterComponents( 'JeeLIB', [TSingleInstance] );
end;

end.