Chip 2001 October/Chip_2001-10_cd1.bin/zkuste/delphi/kolekce/d456/DCSLIB25.ZIP/DCTray.pas

Pascal/Delphi Source File | 2001-06-25 | 18.5 KB | 681 lines

{
 BUSINESS CONSULTING
 s a i n t - p e t e r s b u r g

         Components Library for Borland Delphi 4.x, 5.x
         Copyright (c) 1998-2000 Alex'EM

}
unit DCTray;
{$I DCConst.inc}

interface

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

const
  NIF_INFO     = $00000010;

  NIIF_NONE    = $00000000;
  NIIF_INFO    = $00000001;
  NIIF_WARNING = $00000002;
  NIIF_ERROR   = $00000003;

  NOTIFYICONDATA_V1_SIZE = 88;

type

  PNotifyIconDataEx = ^TNotifyIconDataEx;
  TNotifyIconDataEx = record
    cbSize: DWORD;
    Wnd: HWND;
    uID: UINT;
    uFlags: UINT;
    uCallbackMessage: UINT;
    hIcon: HICON;
    szTip: array [0..MAXCHAR] of AnsiChar;
    {Windows 5.x support}
    dwState: DWORD;
    dwStateMask: DWORD;
    szInfo: array[0..MAXBYTE] of AnsiChar;
    uTimeout: UINT;
    szInfoTitle: array [0..63] of AnsiChar;
    dwInfoFlags: DWORD;
  end;

  TBaloonTimeout  = 10..30;
  TBaloonInfoType = (biNone, biInfo, biWarning, biError);
  TMouseButtons   = set of TMouseButton;

  TDCTrayIcon = class(TComponent)
  private
    FHandle: HWnd;
    FActive: Boolean;
    FAdded: Boolean;
    FClicked: TMouseButtons;
    FIconData: TNotifyIconDataEx;
    FIcon: TIcon;
    FDestroying: Boolean;
    FHint: string;
    FShowDesign: Boolean;
    FPopupMenu: TPopupMenu;
    FOnClick: TMouseEvent;
    FOnDblClick: TNotifyEvent;
    FOnMouseMove: TMouseMoveEvent;
    FOnMouseDown: TMouseEvent;
    FOnMouseUp: TMouseEvent;
    FStartMinimized: boolean;
    procedure ChangeIcon;
    procedure SendCancelMode;
    function CheckMenuPopup(X, Y: Integer): Boolean;
    function CheckDefaultMenuItem: Boolean;
    procedure SetHint(const Value: string);
    procedure SetIcon(Value: TIcon);
    procedure SetPopupMenu(Value: TPopupMenu);
    procedure Activate;
    procedure Deactivate;
    procedure SetActive(Value: Boolean);
    procedure SetShowDesign(Value: Boolean);
    procedure IconChanged(Sender: TObject);
    procedure WndProc(var Message: TMessage);
    function GetActiveIcon: TIcon;
    procedure LoadDefaultIcon;
    function Win2k: boolean;
  protected
    procedure DblClick; dynamic;
    procedure DoClick(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); dynamic;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); dynamic;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); dynamic;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); dynamic;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure UpdateNotifyData; virtual;
    property Handle: HWnd read FHandle;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Hide;
    procedure Show;
    procedure ShowBaloonToolTip(const Info, InfoTitle: string;
      const BaloonType: TBaloonInfoType; const Timeout: TBaloonTimeout);
  published
    property Active: Boolean read FActive write SetActive default True;
    property Hint: string read FHint write SetHint;
    property Icon: TIcon read FIcon write SetIcon;
    property PopupMenu: TPopupMenu read FPopupMenu write SetPopupMenu;
    property ShowDesign: Boolean read FShowDesign write SetShowDesign stored False;
    property OnClick: TMouseEvent read FOnClick write FOnClick;
    property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
    property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
    property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
    property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
    property StartMinimized: boolean read FStartMinimized write FStartMinimized;
  end;

type
  TExecState = (esNormal, esMinimized, esMaximized, esHidden);

type
  TPreviousInstance = class(TObject)
  private
    FMessageID: DWORD;
    FMutexHandle: THandle;
    FhPrevInst: boolean;
    FNewWndProc: Pointer;
    FDefWndProc: Pointer;
  protected
    procedure NewWndProc(var Message: TMessage);
  public
    destructor Destroy; override;
    procedure SethPrevInst;
    property MutexHandle: THandle read FMutexHandle;
    property hPrevInst: boolean read FhPrevInst write FhPrevInst;
    property MessageID: DWORD read FMessageID;
  end;

function CheckToMultyInstance: boolean;
function FileExecute(const FileName, Params, StartDir: string;
  InitialState: TExecState): THandle;
function FileExecuteWait(const FileName, Params, StartDir: string;
  InitialState: TExecState): Integer;

var
  PreviousInstance: TPreviousInstance;

implementation

const
  ShowCommands: array[TExecState] of Integer =
    (SW_SHOWNORMAL, SW_MINIMIZE, SW_SHOWMAXIMIZED, SW_HIDE);

function FileExecute(const FileName, Params, StartDir: string;
  InitialState: TExecState): THandle;
begin
  Result := ShellExecute(Application.Handle, nil, PChar(FileName),
    PChar(Params), PChar(StartDir), ShowCommands[InitialState]);
end;

function FileExecuteWait(const FileName, Params, StartDir: string;
  InitialState: TExecState): Integer;
var
  Info: TShellExecuteInfo;
  ExitCode: DWORD;
begin
  FillChar(Info, SizeOf(Info), 0);
  Info.cbSize := SizeOf(TShellExecuteInfo);
  with Info do begin
    fMask := SEE_MASK_NOCLOSEPROCESS;
    Wnd := Application.Handle;
    lpFile := PChar(FileName);
    lpParameters := PChar(Params);
    lpDirectory := PChar(StartDir);
    nShow := ShowCommands[InitialState];
  end;
  if ShellExecuteEx(@Info) then begin
    repeat
      Application.ProcessMessages;
      GetExitCodeProcess(Info.hProcess, ExitCode);
    until (ExitCode <> STILL_ACTIVE) or Application.Terminated;
    Result := ExitCode;
  end
  else Result := -1;
end;

procedure SwitchToWindow(Wnd: HWnd; Restore: Boolean);
begin
  if IsWindowEnabled(Wnd) then begin
    SetForegroundWindow(Wnd);
    if Restore and IsWindowVisible(Wnd) then begin
      if not IsZoomed(Wnd) then
        SendMessage(Wnd, WM_SYSCOMMAND, SC_RESTORE, 0);
      SetFocus(Wnd);
    end;
  end;
end;

function GetShiftState: 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;

constructor TDCTrayIcon.Create(AOwner: Tcomponent);
begin
  inherited Create(AOwner);
  {$IFDEF DELPHI_V6}
    FHandle := Classes.AllocateHWnd(WndProc);
  {$ELSE}
    FHandle := AllocateHWnd(WndProc);
  {$ENDIF}
  FIcon := TIcon.Create;
  FIcon.OnChange := IconChanged;
  FActive        := True;
  StartMinimized := False;
  LoadDefaultIcon;
end;

destructor TDCTrayIcon.Destroy;
begin
  FDestroying := True;
  FIcon.OnChange := nil;
  Deactivate;
  {$IFDEF DELPHI_V6}
    Classes.DeallocateHWnd(FHandle);
  {$ELSE}
    DeallocateHWnd(FHandle);
  {$ENDIF}
  FIcon.Free;
  FIcon := nil;
  inherited Destroy;
end;

procedure TDCTrayIcon.Loaded;
begin
  inherited Loaded;
  if FActive and not (csDesigning in ComponentState) then Activate;

  if FStartMinimized then
  begin
    Application.ShowMainForm := False;
    ShowWindow(Application.Handle, SW_HIDE);
  end;

end;

procedure TDCTrayIcon.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (AComponent = PopupMenu) and (Operation = opRemove) then
    PopupMenu := nil;
end;

procedure TDCTrayIcon.SetPopupMenu(Value: TPopupMenu);
begin
  FPopupMenu := Value;
  if Value <> nil then Value.FreeNotification(Self);
end;

procedure TDCTrayIcon.SendCancelMode;
var
  F: TForm;
begin
  if not ((csDestroying in ComponentState) or FDestroying) then begin
    F := Screen.ActiveForm;
    if F = nil then F := Application.MainForm;
    if F <> nil then F.SendCancelMode(nil);
  end;
end;

function TDCTrayIcon.CheckMenuPopup(X, Y: Integer): Boolean;
begin
  Result := False;
  if not (csDesigning in ComponentState) and Active and
    (PopupMenu <> nil) and PopupMenu.AutoPopup then
  begin
    PopupMenu.PopupComponent := Self;
    SendCancelMode;
    SwitchToWindow(FHandle, False);
    Application.ProcessMessages;
    try
      PopupMenu.Popup(X, Y);
    finally
      SwitchToWindow(FHandle, False);
    end;
    Result := True;
  end;
end;

function TDCTrayIcon.CheckDefaultMenuItem: Boolean;
var
  Item: TMenuItem;
  I: Integer;
begin
  Result := False;
  if not (csDesigning in ComponentState) and Active and
    (PopupMenu <> nil) and (PopupMenu.Items <> nil) then
  begin
    I := 0;
    while (I < PopupMenu.Items.Count) do begin
      Item := PopupMenu.Items[I];
      if Item.Default and Item.Enabled then begin
        Item.Click;
        Result := True;
        Break;
      end;
      Inc(I);
    end;
  end;
end;

procedure TDCTrayIcon.SetIcon(Value: TIcon);
begin
  FIcon.Assign(Value);
end;

function TDCTrayIcon.GetActiveIcon: TIcon;
begin
  Result := FIcon;
end;

procedure TDCTrayIcon.SetActive(Value: Boolean);
begin
  if (Value <> FActive) then begin
    FActive := Value;
    if not (csDesigning in ComponentState) then
      if Value then Activate else Deactivate;
  end;
end;

procedure TDCTrayIcon.Show;
begin
  Active := True;
end;

procedure TDCTrayIcon.Hide;
begin
  Active := False;
end;

procedure TDCTrayIcon.SetShowDesign(Value: Boolean);
begin
  if (csDesigning in ComponentState) then begin
    if Value then Activate else Deactivate;
    FShowDesign := FAdded;
  end;
end;

procedure TDCTrayIcon.IconChanged(Sender: TObject);
begin
  ChangeIcon;
end;

procedure TDCTrayIcon.SetHint(const Value: string);
begin
  if FHint <> Value then begin
    FHint := Value;
    ChangeIcon;
  end;
end;

procedure TDCTrayIcon.UpdateNotifyData;
 var
  Ico: TIcon;
begin
  with FIconData do
  begin
    if Win2k then
      cbSize := SizeOf(TNotifyIconDataEx)
    else
      cbSize := NOTIFYICONDATA_V1_SIZE;
    Wnd := FHandle;
    uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
    Ico := GetActiveIcon;
    if Ico <> nil then
      hIcon := Ico.Handle
    else
      hIcon := INVALID_HANDLE_VALUE;
    StrPCopy(szTip, GetShortHint(FHint));
    uCallbackMessage := CM_TRAYICON;
    uID := 0;
  end;
end;

procedure TDCTrayIcon.Activate;
var
  Ico: TIcon;
begin
  Deactivate;
  Ico := GetActiveIcon;
  if (Ico <> nil) and not Ico.Empty then
  begin
    FClicked := [];
    UpdateNotifyData;
    FAdded := Shell_NotifyIcon(NIM_ADD, @FIconData);
    if (GetShortHint(FHint) = '') and FAdded then
      Shell_NotifyIcon(NIM_MODIFY, @FIconData);
  end;
end;

procedure TDCTrayIcon.Deactivate;
begin
  Shell_NotifyIcon(NIM_DELETE, @FIconData);
  FAdded := False;
  FClicked := [];
end;

procedure TDCTrayIcon.ChangeIcon;
var
  Ico: TIcon;
begin
  if FAdded then begin
    Ico := GetActiveIcon;
    if (Ico <> nil) and not Ico.Empty then begin
      UpdateNotifyData;
      Shell_NotifyIcon(NIM_MODIFY, @FIconData);
    end
    else Deactivate;
  end
  else begin
    if ((csDesigning in ComponentState) and FShowDesign) or
      (not (csDesigning in ComponentState) and FActive) then Activate;
  end;
end;

procedure TDCTrayIcon.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FOnMouseMove) then FOnMouseMove(Self, Shift, X, Y);
end;

procedure TDCTrayIcon.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, X, Y);
end;

procedure TDCTrayIcon.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FOnMouseUp) then FOnMouseUp(Self, Button, Shift, X, Y);
end;

procedure TDCTrayIcon.DblClick;
begin
  if not CheckDefaultMenuItem and Assigned(FOnDblClick) then
    FOnDblClick(Self);
end;

procedure TDCTrayIcon.DoClick(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  if (Button = mbRight) and CheckMenuPopup(X, Y) then Exit;
  if Assigned(FOnClick) then FOnClick(Self, Button, Shift, X, Y);
end;

procedure TDCTrayIcon.WndProc(var Message: TMessage);
 var
  P: TPoint;
  Shift: TShiftState;
begin
  try
    with Message do
    begin
      if Msg = CM_TRAYICON then begin
        case lParam of
          WM_LBUTTONDBLCLK:
            begin
              GetCursorPos(P);
              MouseDown(mbLeft, GetShiftState + [ssDouble], P.X, P.Y);
              DblClick;
            end;
          WM_RBUTTONDBLCLK:
            begin
              GetCursorPos(P);
              MouseDown(mbRight, GetShiftState + [ssDouble], P.X, P.Y);
            end;
          WM_MBUTTONDBLCLK:
            begin
              GetCursorPos(P);
              MouseDown(mbMiddle, GetShiftState + [ssDouble], P.X, P.Y);
            end;
          WM_MOUSEMOVE:
            begin
              GetCursorPos(P);
              MouseMove(GetShiftState, P.X, P.Y);
            end;
          WM_LBUTTONDOWN:
            begin
              GetCursorPos(P);
              MouseDown(mbLeft, GetShiftState + [ssLeft], P.X, P.Y);
              Include(FClicked, mbLeft);
            end;
          WM_LBUTTONUP:
            begin
              Shift := GetShiftState + [ssLeft];
              GetCursorPos(P);
              if (mbLeft in FClicked) then begin
                Exclude(FClicked, mbLeft);
                DoClick(mbLeft, Shift, P.X, P.Y);
              end;
              MouseUp(mbLeft, Shift, P.X, P.Y);
            end;
          WM_RBUTTONDOWN:
            begin
              GetCursorPos(P);
              MouseDown(mbRight, GetShiftState + [ssRight], P.X, P.Y);
              Include(FClicked, mbRight);
            end;
          WM_RBUTTONUP:
            begin
              Shift := GetShiftState + [ssRight];
              GetCursorPos(P);
              if (mbRight in FClicked) then begin
                Exclude(FClicked, mbRight);
                DoClick(mbRight, Shift, P.X, P.Y);
              end;
              MouseUp(mbRight, Shift, P.X, P.Y);
            end;
          WM_MBUTTONDOWN:
            begin
              GetCursorPos(P);
              MouseDown(mbMiddle, GetShiftState + [ssMiddle], P.X, P.Y);
            end;
          WM_MBUTTONUP:
            begin
              GetCursorPos(P);
              MouseUp(mbMiddle, GetShiftState + [ssMiddle], P.X, P.Y);
            end;
        end;
      end
      else Result := DefWindowProc(FHandle, Msg, wParam, lParam);
    end
  except
    Application.HandleException(Self);
  end;
end;

destructor TPreviousInstance.Destroy;
begin
  CloseHandle(PreviousInstance.MutexHandle);
  if FDefWndProc <> nil then
    SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(FDefWndProc));
  {$IFDEF DELPHI_V6}
    Classes.FreeObjectInstance(FNewWndProc);
  {$ELSE}
    FreeObjectInstance(FNewWndProc);
  {$ENDIF}
  inherited;
end;

procedure TPreviousInstance.NewWndProc(var Message: TMessage);
begin
  with Message do
  begin
    if Msg = FMessageID then
    begin
      if IsIconic(Application.Handle) then
      begin
        Application.MainForm.WindowState := wsNormal;
        Application.Restore;
      end;
      SetForegroundWindow(Application.Handle);
    end
    else
      Result := CallWindowProc(FDefWndProc, Application.Handle, Msg, WParam, LParam);
  end;
end;

procedure TPreviousInstance.SethPrevInst;
begin
  FMessageID   := RegisterWindowMessage(PChar(Application.Title));
  FMutexHandle := CreateMutex(nil, TRUE, PChar(Application.Title));
  if MutexHandle <> 0 then
  begin
    if GetLastError = ERROR_ALREADY_EXISTS then
      hPrevInst := True
    else begin
      hPrevInst := False;
      {$IFDEF DELPHI_V6}
        FNewWndProc := Classes.MakeObjectInstance(NewWndProc);
      {$ELSE}
        FNewWndProc := MakeObjectInstance(NewWndProc);
      {$ENDIF}
      FDefWndProc := Pointer(SetWindowLong(Application.Handle, GWL_WNDPROC,
        LongInt(FNewWndProc)));
    end;
  end
  else
    hPrevInst := FALSE;
end;

function CheckToMultyInstance: boolean;
 type
   TBroadcastSystemMessage = function(Flags: DWORD; Recipients: PDWORD;
     uiMessage: UINT; wParam: WPARAM; lParam: LPARAM): Longint;
 var
  BSMReceptions: DWORD;
  User32Dll: THandle;
  BroadCastSystemMessageAW: TBroadcastSystemMessage;
begin
  if PreviousInstance.hPrevInst then
  begin
    Application.ShowMainForm := False;
    BSMReceptions := BSM_APPLICATIONS;
    User32Dll := GetModuleHandle(user32);
    if User32Dll <> 0 then
    begin
      {Under Win95 fixed bug with BroadCastSystemMessage}
      if (Win32Platform <> VER_PLATFORM_WIN32_NT) and (Win32MajorVersion <= 4)
        or ((Win32MajorVersion = 4) and (Win32MinorVersion < 10)) then
        @BroadCastSystemMessageAW := GetProcAddress(User32Dll, 'BroadcastSystemMessageW')
      else
        @BroadCastSystemMessageAW := GetProcAddress(User32Dll, 'BroadcastSystemMessageA');

      if @BroadCastSystemMessageAW <> nil then
        BroadCastSystemMessageAW(BSF_IGNORECURRENTTASK or BSF_POSTMESSAGE,
          @BSMReceptions, PreviousInstance.MessageID, 0 ,0);
    end;
    Result := True
  end
  else
    Result := False;
end;

procedure TDCTrayIcon.LoadDefaultIcon;
begin
  FIcon.Handle := LoadIcon(hInstance, 'MAINICONX16');
  if FIcon.Handle = 0 then
    FIcon.Handle := LoadIcon(0, IDI_WINLOGO);
end;

function TDCTrayIcon.Win2k: boolean;
begin
  Result := (Win32MajorVersion > 4) and (Win32Platform = VER_PLATFORM_WIN32_NT);
end;

procedure TDCTrayIcon.ShowBaloonToolTip(const Info, InfoTitle: string;
  const BaloonType: TBaloonInfoType; const Timeout: TBaloonTimeout);
 const
   aBaloonInfoType: array[TBaloonInfoType] of DWORD =
     (NIIF_NONE, NIIF_INFO, NIIF_WARNING, NIIF_ERROR);
 var
  Ico: TIcon;
begin
  with FIconData do
  begin
    if Win2k then
      cbSize := SizeOf(TNotifyIconDataEx)
    else
      cbSize := NOTIFYICONDATA_V1_SIZE;
    Wnd := FHandle;
    uFlags := NIF_INFO;
    Ico := GetActiveIcon;
    if Ico <> nil then
      hIcon := Ico.Handle
    else
      hIcon := INVALID_HANDLE_VALUE;
    uID := 0;
    uTimeout := 1000 * Timeout;

    {Hide previous tooltip}
    StrPCopy(szInfoTitle, '');
    StrPCopy(szInfo, '');
    Shell_NotifyIcon(NIM_MODIFY, @FIconData);

    StrPCopy(szInfoTitle, InfoTitle);
    StrPCopy(szInfo, Info);
    dwInfoFlags := aBaloonInfoType[BaloonType];
    Shell_NotifyIcon(NIM_MODIFY, @FIconData);
  end;
end;

initialization
  PreviousInstance := TPreviousInstance.Create;
  PreviousInstance.SethPrevInst;

finalization
  PreviousInstance.Free;

end.