anitray.pas

Delphi 开发的的热键操作 很值得看的

unit AniTray;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Menus,
  WComp, ExtCtrls, ShellAPI, AboutPrp, AniIcons;

type
  TTIMouseEvent = procedure(Sender: TObject; Button: TMouseButton; Shift: TShiftState) of object;
  TTIMouseMove  = TNotifyEvent;

  TTrayIconStyle = (tsNormal, tsAnimated);

  TAnimatedTrayIcon = class(TWindowedComponent)
  private
    { property variables }
    FAboutInfo     : TAboutInfo;
    FActive        : Boolean;
    FIcon          : TIcon;
    FIcons         : TAnimatedIcons;
    FHint          : String;
    FPopupMenu     : TPopupMenu;
    FRepeatCount   : Integer;
    FShowHint      : Boolean;
    FStyle         : TTrayIconStyle;
    { event variables }
    FOnClick       : TNotifyEvent;
    FOnDblClick    : TNotifyEvent;
    FOnEndAnimation: TNotifyEvent;
    FOnMouseDown   : TTIMouseEvent;
    FOnMouseMove   : TTIMouseMove;
    FOnMouseUp     : TTIMouseEvent;
    { internal variables }
    FVisAppStyle   : Integer;
    FInvAppStyle   : Integer;
    FCallBackMsg   : Word;
    FPreventClick  : Boolean;
    { Property setting routines }
    procedure SetActive(Value: Boolean);
    procedure SetAnimatedIcons(Value: TAnimatedIcons);
    procedure SetHint(Value: String);
    procedure SetIcon(Value: TIcon);
    procedure SetPopupMenu(Value: TPopupMenu);
    procedure SetRepeatCount(Value: Integer);
    procedure SetShowHint(Value: Boolean);
    procedure SetStyle(Value: TTrayIconStyle);
  protected
    { Internal routines }
    procedure ActivateTrayIcon;
    procedure ShellNotifyIcon(Msg: DWord; Flags: UInt; Icon: TIcon);
    procedure HandleTrayMessage(const Msg: Longint);
    function  LoadWorldIcon: THandle;
    procedure IconChange(Sender: TObject);
    function  GetControlKeys(const Shift: TShiftState): TShiftState;
    procedure NewFrame(Sender: TObject; Frame: Integer);
    procedure AnimStopped(Sender: TObject);
    function  GetActiveIcon: TIcon;
    { event dispatch routines }
    procedure DoClick;
    procedure DoDblClick;
    procedure DoMouseDown(Button: TMouseButton; Shift: TShiftState);
    procedure DoMouseMove;
    procedure DoMouseUp(Button: TMouseButton);
    { Overrides }
    procedure WndProc(var Msg: TMessage); override;
    procedure Notification(AComponent: TComponent; AOperation: TOperation); override;
    procedure Loaded; override;
  public
    { Constructor / destructor overrides }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    { Methods }
    procedure HideAppIcon;
    procedure ShowAppIcon;
  published
    { Properties }
    property About      : TAboutInfo     read FAboutInfo;
    property Active     : Boolean        read FActive      write SetActive   default False;
    property Icon       : TIcon          read FIcon        write SetIcon;
    property Animation  : TAnimatedIcons read FIcons       write SetAnimatedIcons;
    property Hint       : String         read FHint        write SetHint;
    property PopupMenu  : TPopupMenu     read FPopupMenu   write SetPopupMenu;
    property RepeatCount: Integer        read FRepeatCount write SetRepeatCount default 0;
    property ShowHint   : Boolean        read FShowHint    write SetShowHint default True;
    property Style      : TTrayIconStyle read FStyle       write SetStyle    default tsNormal;
    { Events }
    property OnClick       : TNotifyEvent   read FOnClick        write FOnClick;
    property OnDblClick    : TNotifyEvent   read FOnDblClick     write FOnDblClick;
    property OnEndAnimation: TNotifyEvent   read FOnEndAnimation write FOnEndAnimation;
    property OnMouseDown   : TTIMouseEvent  read FOnMouseDown    write FOnMouseDown;
    property OnMouseMove   : TTIMouseMove   read FOnMouseMove    write FOnMouseMove;
    property OnMouseUp     : TTIMouseEvent  read FOnMouseUp      write FOnMouseUp;
  end;

{$R ANITRAY.RES}

implementation

{ TAnimatedTrayIcon }
constructor TAnimatedTrayIcon.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCallbackMsg := RegisterWindowMessage('TAnimatedTrayIconCallBackMsg');
  FIcon := TIcon.Create;
  FIcon.Handle := LoadWorldIcon;
  FIcon.OnChange := IconChange;
  FIcons := TAnimatedIcons.Create(is16x16);
  FIcons.OnNewFrame := NewFrame;
  FIcons.OnStopped  := AnimStopped;
  FShowHint := True;
  FRepeatCount := 0;
  FAboutInfo := TAboutInfo.Create;
  with FAboutInfo do
   begin
     CopyrightDate := '1996/1997';
     Company := 'SheAr software, Enschede, the Netherlands';
     Description := 'Non-visible component that allows you to put animated icons in the Windows 95 or NT 4.0 system tray.';
   end;
  FVisAppStyle   := GetWindowLong(Application.Handle, GWL_EXSTYLE);
  FInvAppStyle   := FVisAppStyle or WS_EX_TOOLWINDOW and (not WS_EX_APPWINDOW);
end;

destructor TAnimatedTrayIcon.Destroy;
begin
  Active := False;
  FIcon.Free;
  FIcons.Free;
  FAboutInfo.Free;
  inherited Destroy;
end;

procedure TAnimatedTrayIcon.Loaded;
begin
  inherited Loaded;
  ActivateTrayIcon;
end;

procedure TAnimatedTrayIcon.ActivateTrayIcon;
const
  Values: array[Boolean] of DWord = (NIM_DELETE, NIM_ADD);
begin
  if Active then
   repeat
     Application.ProcessMessages;
   until FindWindow('Shell_TrayWnd', nil)<>0;
  ShellNotifyIcon(Values[Active], NIF_MESSAGE or NIF_ICON or NIF_TIP, GetActiveIcon);
end;

procedure TAnimatedTrayIcon.HandleTrayMessage(const Msg: Longint);
var
  Point: TPoint;
begin
  case Msg of
    WM_LBUTTONDOWN  : begin
                        FPreventClick := False;
                        DoMouseDown(mbLeft, []);
                      end;
    WM_MBUTTONDOWN  : DoMouseDown(mbMiddle, []);
    WM_RBUTTONDOWN  : begin
                        DoMouseDown(mbRight, []);
                        if Assigned(PopupMenu) then
                         begin
                           if Screen.ActiveForm<>nil then
                            SetForeGroundWindow(Screen.ActiveForm.Handle)
                           else
                            SetForeGroundWindow(TForm(Owner).Handle);
                           GetCursorPos(Point);
                           PopupMenu.Popup(Point.X, Point.Y);
                           PostMessage((Owner As TForm).Handle, WM_USER, 0, 0);
                         end;
                      end;
    WM_LBUTTONUP    : begin
                        if not FPreventClick then DoClick;
                        DoMouseUp(mbLeft);
                      end;
    WM_RBUTTONUP    : DoMouseUp(mbRight);
    WM_MBUTTONUP    : DoMouseUp(mbMiddle);
    WM_LBUTTONDBLCLK: begin
                        FPreventClick := True;
                        DoDblClick;
                        DoMouseDown(mbLeft, [ssDouble]);
                      end;
    WM_RBUTTONDBLCLK: DoMouseDown(mbRight, [ssDouble]);
    WM_MBUTTONDBLCLK: DoMouseDown(mbMiddle, [ssDouble]);
    WM_MOUSEMOVE    : DoMouseMove;
  end;
end;

procedure TAnimatedTrayIcon.WndProc(var Msg: TMessage);
begin
  with Msg do
   if (Msg=FCallBackMsg) and (wParam=0) then
    HandleTrayMessage(lParam)
   else
    inherited;
end;

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

{ Public methods }
procedure TAnimatedTrayIcon.HideAppIcon;
begin
  SetWindowLong(Application.Handle, GWL_EXSTYLE, FInvAppStyle);
end;

procedure TAnimatedTrayIcon.ShowAppIcon;
begin
  SetWindowLong(Application.Handle, GWL_EXSTYLE, FVisAppStyle);
end;

{ Property get/set routines }
procedure TAnimatedTrayIcon.SetActive(Value: Boolean);
begin
  if FActive <> Value then
   begin
     FActive := Value;
     ActivateTrayIcon;
   end;
end;

procedure TAnimatedTrayIcon.SetHint(Value : String);
begin
  if FHint <> Value then
   begin
     FHint := Value;
     if Active then ShellNotifyIcon(NIM_MODIFY, NIF_TIP, FIcon);
   end;
end;

procedure TAnimatedTrayIcon.SetIcon(Value: TIcon);
begin
  FIcon.Assign(Value);
  if FIcon.Empty then FIcon.Handle := LoadWorldIcon;
  if Active and (FStyle=tsNormal) then ShellNotifyIcon(NIM_MODIFY, NIF_ICON, FIcon);
end;

procedure TAnimatedTrayIcon.SetShowHint(Value: Boolean);
begin
  if FShowHint<>Value then
   begin
     FShowHint := Value;
     if Active then ShellNotifyIcon(NIM_MODIFY, NIF_TIP, FIcon);
   end;
end;

procedure TAnimatedTrayIcon.SetStyle(Value: TTrayIconStyle);
begin
  if FStyle<>Value then
   begin
     FStyle := Value;
     if Active then ShellNotifyIcon(NIM_MODIFY, NIF_ICON, GetActiveIcon);
   end;
end;

procedure TAnimatedTrayIcon.SetAnimatedIcons(Value: TAnimatedIcons);
begin
  FIcons.Assign(Value);
end;

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

procedure TAnimatedTrayIcon.SetRepeatCount(Value: Integer);
begin
  if (Value>=0) and (Value<>FRepeatCount) then
   begin
     FRepeatCount := Value;
     if Active then ShellNotifyIcon(NIM_MODIFY, NIF_ICON, GetActiveIcon);
   end;
end;

{ Internal protected methods }
procedure TAnimatedTrayIcon.IconChange(Sender: TObject);
begin
  if Active then ShellNotifyIcon(NIM_MODIFY, NIF_ICON, GetActiveIcon);
end;

procedure TAnimatedTrayIcon.AnimStopped(Sender: TObject);
begin
  if (RepeatCount<>0) and Assigned(FOnEndAnimation) then
   FOnEndAnimation(Self);
end;

procedure TAnimatedTrayIcon.NewFrame(Sender: TObject; Frame: Integer);
begin
  ShellNotifyIcon(NIM_MODIFY, NIF_ICON, FIcons[Frame]);
end;

function TAnimatedTrayIcon.LoadWorldIcon: THandle;
begin
  Result := LoadImage(hInstance, 'TRAYICON', IMAGE_ICON, 16, 16, 0) //LR_LOADREALSIZE);
end;

function TAnimatedTrayIcon.GetActiveIcon: TIcon;
begin
  if (FStyle=tsAnimated) and (FIcons.Count>0) then
   begin
     if Active and not (csDesigning in ComponentState) then FIcons.Play(FRepeatCount);
     Result := FIcons[0];
   end
  else
   begin
     if FIcons.Playing then FIcons.Stop;
     Result := FIcon;
   end;
end;

procedure TAnimatedTrayIcon.ShellNotifyIcon(Msg: DWord; Flags: UInt; Icon: TIcon);
var
  NotifyData  : TNotifyIconData;
begin
  if (csDesigning in ComponentState) or (csLoading in ComponentState) then Exit;
  with NotifyData do begin
    cbSize := SizeOf(TNotifyIconData);
    if ShowHint then
     StrPLCopy(szTip, PChar(Hint), SizeOf(szTip))
    else
     szTip[0] := #0;
    uFlags := Flags;
    uID := 0;
    Wnd := Handle;
    uCallbackMessage := FCallBackMsg;
    hIcon  := Icon.Handle;
  end;
  Shell_NotifyIcon(Msg, @NotifyData);
end;

function TAnimatedTrayIcon.GetControlKeys(const Shift: TShiftState): TShiftState;
begin
  Result := Shift;
  if GetAsyncKeyState(VK_CONTROL)<0 then Include(Result, ssCtrl);
  if GetAsyncKeyState(VK_MENU)<0    then Include(Result, ssAlt);
  if GetAsyncKeyState(VK_SHIFT)<0   then Include(Result, ssShift);
end;

{ Event dispatch routines }
procedure TAnimatedTrayIcon.DoClick;
begin
  if Assigned(FOnClick) then FOnClick(Self);
end;

procedure TAnimatedTrayIcon.DoDblClick;
begin
  if Assigned(FOnDblClick) then FOnDblClick(Self);
end;

procedure TAnimatedTrayIcon.DoMouseDown(Button: TMouseButton; Shift: TShiftState);
begin
  if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, GetControlKeys(Shift));
end;

procedure TAnimatedTrayIcon.DoMouseMove;
begin
  if Assigned(FOnMouseMove) then FOnMouseMove(Self);
end;

procedure TAnimatedTrayIcon.DoMouseUp(Button: TMouseButton);
begin
  if Assigned(FOnMouseUp) then FOnMouseUp(Self, Button, GetControlKeys([]));
end;

end.