//
// Componentware for Delphi - TrayIcon Component Release 1.16
//   Copyright(C) 1996-1998 Yukio Tsujihara
//
// Module      : トレイアイコンコンポーネント
// Last Update : 10/27/98
// Author      : Yukio Tsujihara
//
// Revision    : Taro Kato
// Last Update : 01/25/2001

unit TrayIcon;

interface

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

const
  NotifyIconErrMessage = 'タスクトレイにアイコンを登録できません。';
  WM_NotifyIconMessage = WM_User + 200;

type
  // ENotifyIconError例外の定義
  ENotifyIconError = class(Exception);

  // TTrayIconMode列挙型の定義
  TTrayIconMode = (tiAddIcon, tiModifyIcon, tiDeleteIcon);

  // TAnimateMode列挙型の定義
  TAnimateMode = (amAutomatic, amManual);

  // TrayIconアニメーションスレッドクラスの疑似定義
  TTrayIconAnimate = class;

  TTrayIcon = class(TComponent)
  private
    FAnimated: Boolean;
    FAnimateIcons: TImageList;
    FAnimateMode: TAnimateMode;
    FAnimateRate: Integer;
    FAutoPopup: Boolean;
    FEnabled: Boolean;
    FIcon: TIcon;
    FLBPopupMenu: TPopupMenu;
    FRBPopupMenu: TPopupMenu;
    FTipHelp: String;
    FVisible: Boolean;
    FOnClick: TNotifyEvent;
    FOnDblClick: TNotifyEvent;
    FOnMouseMove: TMouseMoveEvent;
    FOnMouseDown, FOnMouseUp: TMouseEvent;

    AnimateThread: TTrayIconAnimate;
    IconID: UINT;
    IconRegisted: Boolean;
    NIconData: PNotifyIconDataA;
    SingleClickExec: Boolean;

    FReadStateNext: Boolean;
    function GetIconHandle: THandle;
  protected
    procedure IconChange(Sender: TObject);

    procedure SetAnimateIcons(Value: TImageList);
    procedure SetAnimateRate(Value: Integer);
    procedure SetEnabled(Value: Boolean);
    procedure SetIcon(Value: TIcon);
    procedure SetLBPopupMenu(Value: TPopupMenu);
    procedure SetRBPopupMenu(Value: TPopupMenu);
    procedure SetTipHelp(Value: String);
    procedure SetTrayIcon(Value: TTrayIconMode);
    procedure SetVisible(Value: Boolean);
    procedure ReadState(Reader: TReader); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation);
      override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure Loaded; override;
    destructor Destroy; override;
    procedure AnimeteModeChange;
    procedure AnimatePlay(AAnimateMode: TAnimateMode);
    procedure AnimateStep;
    procedure AnimateStop;

    property Animated: Boolean read FAnimated;
    property AnimateMode: TAnimateMode read FAnimateMode;
  published
    property AnimateIcons: TImageList read FAnimateIcons write SetAnimateIcons;
    property AnimateRate: Integer read FAnimateRate write SetAnimateRate
      default 500;
    property AutoPopup: Boolean read FAutoPopup write FAutoPopup default True;
    property Enabled: Boolean read FEnabled write SetEnabled default True;
    property Icon: TIcon read FIcon write SetIcon;
    property LBPopupMenu: TPopupMenu read FLBPopupMenu write SetLBPopupmenu;
    property RBPopupMenu: TPopupMenu read FRBPopupMenu write SetRBPopupmenu;
    property TipHelp: String read FTipHelp write SetTipHelp;
    property Visible: Boolean read FVisible write SetVisible default False;

    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;

  // シングルクリックスレッドクラスの定義
  TSingleClick = class(TThread)
  protected
    procedure Execute; override;
  public
    constructor Create;
  end;

  // TrayIconアニメーションスレッドクラスの定義
  TTrayIconAnimate = class(TThread)
  private
    AnimateFrame: Integer;
    Icon: TIcon;
    Owner: TTrayIcon;
  protected
    procedure Execute; override;
  public
    constructor Create(AOwner: TTrayIcon);
    destructor Destroy; override;
  end;

  // Shell_NotifyIcon用非表示ウィンドウクラスの定義
  TCallbackWindow = Class(TWinControl)
  private
    FOwner: TTrayIcon;

    procedure CallbackWndProc(var Msg: TMessage); Message WM_NotifyIconMessage;
    procedure OnClick(Sender: TObject);
  end;

procedure Register;

implementation

var
  CallbackWindow: TCallbackWindow;
  IconIDList: TStringList;

constructor TTrayIcon.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  // アイコン登録数のチェック
  if IconIDList.Count > 99 then
  begin
    IconID := 0;
    raise ENotifyIconError.Create(NotifyIconErrMessage);
  end;
  if IconIDList.Count > 0 then
    IconID := StrToInt(IconIDList[IconIDList.Count - 1]) + 1
  else
    IconID := 1;
  IconIDList.AddObject(IntToStr(IconID), Self);

  // プロパティのデフォルト値の設定
  AnimateThread := nil;
  FAnimated := False;
  FAnimateMode := amAutomatic;
  FAnimateRate := 500;
  FAutoPopup := True;
  FEnabled := True;
  FTipHelp := 'TipHelp';
  FVisible := False;
  // Iconプロパティ用アイコンデータ領域確保
  FIcon := TIcon.Create;
  IconRegisted := False;
  // シングルクリック判定用フラグの初期化
  SingleClickExec := False;

  // デザイン時でない場合の初期化
  if not (csDesigning in ComponentState) then
  begin
    // アイコンのOnChangeイベントを設定
    FIcon.OnChange := IconChange;

    // Shell_NotifyIcon用非表示コールバックウィンドウが生成されていない場合
    if CallbackWindow = nil then
    begin
      CallbackWindow := TCallbackWindow.Create(Owner);
      CallbackWindow.Parent := TWinControl(Owner);
    end;

    // Shell_NotifyIcon用データ領域確保と初期化
    New(NIconData);
    with NIconData^ do
    begin
      cbSize := Sizeof(TNotifyIconDataA);
      uCallBackMessage := WM_NotifyIconMessage;
      uID := IconID;
    end;
  end;
end;

procedure TTrayIcon.Loaded;
begin
  FReadStateNext := False; 
  // デザイン時でない場合、アイコンの登録
  if not (csDesigning in ComponentState) then
    SetTrayIcon(tiAddIcon);

  inherited Loaded;
end;

destructor TTrayIcon.Destroy;
begin
  // アイコン登録数オーバによる例外発生時以外、破棄処理
  if IconID <> 0 then
  begin
    // デザイン時でない場合、破棄処理
    if not (csDesigning in ComponentState) then
    begin
      // アニメーションスレッドの破棄
      if AnimateThread <> nil then
      begin
        AnimateThread.Terminate;
        if AnimateThread.Suspended then
          AnimateThread.Resume;
        AnimateThread.Free;
        FAnimated := False;
      end;

      // トレイにアイコンが表示されている場合、アイコンの破棄
      if IconRegisted then
        SetTrayIcon(tiDeleteIcon);

      // Shell_NotifyIcon用データ領域破棄
      Dispose(NIconData);
    end;

    IconIDList.Delete(IconIDList.IndexOf(IntToStr(IconID)));
    FIcon.Free;
  end;

  inherited Destroy;
end;

procedure TTrayIcon.AnimeteModeChange;
begin
  if FAnimated then
  begin
    // 自動→手動へ切り替えた場合
    if FAnimateMode = amAutomatic then
    begin
      FAnimateMode := amManual;
    end
    // 手動→自動へ切り替えた場合
    else
    begin
      FAnimateMode := amAutomatic;
      AnimateThread.Resume;
    end;
  end;
end;

procedure TTrayIcon.AnimatePlay(AAnimateMode: TAnimateMode);
begin
  // アニメーション中でなく、アニメーションアイコンが設定されている場合
  if (not FAnimated) and (FAnimateIcons <> nil) then
  begin
    // アニメーションアイコンに１つ以上のアイコンが登録されている場合、
    // アニメーションを開始
    if FAnimateIcons.Count > 0 then
    begin
      // アニメーションスレッドが未生成の場合
      if AnimateThread = nil then
      begin
        // アニメーションスレッドの生成
        AnimateThread := TTrayIconAnimate.Create(Self);
      end;
      // アニメーション関連の変数を初期化
      FAnimated := True;
      FAnimateMode := AAnimateMode;
      // アニメーションスレッドの再開
      AnimateThread.Resume;
    end;
  end;
end;

procedure TTrayIcon.AnimateStep;
begin
  // アニメーション中で手動アニメーションの場合
  if FAnimated and (FAnimateMode = amManual) then
    AnimateThread.Resume;
end;

procedure TTrayIcon.AnimateStop;
begin
  // アニメーションが開始されている場合、アニメーションを停止
  if FAnimated then
  begin
    // アニメーションスレッドの停止
    FAnimated := False;
    if FAnimateMode = amManual then
      AnimateThread.Resume;
    // アニメーションスレッドが完全に停止するまでループ
    while not AnimateThread.Suspended do;

    // アニメーションアイコンをもとのアイコンに変更
    IconChange(FIcon);  // 2001/01/25 Self->FIcon
  end;
end;

procedure TTrayIcon.IconChange(Sender: TObject);
begin
  // トレイにアイコンが表示されている場合、アイコンの変更
  if IconRegisted and (not (FAnimated and (FAnimateMode = amAutomatic))) then
    SetTrayIcon(tiModifyIcon);
end;

procedure TTrayIcon.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);

  // フォーム上の他のコンポーネントが削除された場合
  if (Operation = opRemove) then
  begin
    // 削除されたコンポーネントがTPopupMenuで、
    // LBPopupMenu、RBPopupMenuに設定されていた場合、設定を無効に変更
    if AComponent is TPopupMenu then
    begin
      if AComponent = FLBPopupMenu then
        FLBPopupMenu := nil
      else if AComponent = FRBPopupMenu then
        FRBPopupMenu := nil;
    end
    // 削除されたコンポーネントがTImageListで、
    // AnimateIconsに設定された場合、設定を無効に変更
    else if (AComponent is TImageList) and (AComponent = FAnimateIcons) then
      FAnimateIcons := nil;
  end;
end;

procedure TTrayIcon.ReadState(Reader: TReader);
begin
  if not FReadStateNext then
  begin
    FReadStateNext := True;
    TipHelp := '';
  end;
  inherited;
end;

procedure TTrayIcon.SetAnimateIcons(Value: TImageList);
begin
  if (Value <> FAnimateIcons) and (not FAnimated) then
    FAnimateIcons := Value;
  if FAnimateIcons <> nil then
    Value.FreeNotification(Self);
end;

procedure TTrayIcon.SetAnimateRate(Value: Integer);
begin
  if Value <> FAnimateRate then
  begin
    if Value < 100 then
      Value := 100;
    FAnimateRate := Value;
  end;
end;

procedure TTrayIcon.SetEnabled(Value: Boolean);
begin
  if Value <> FEnabled then
  begin
    FEnabled := Value;
    if not Value then
      SingleClickExec := False;
  end;
end;

procedure TTrayIcon.SetIcon(Value: TIcon);
begin
  if Value <> FIcon then
  begin
    // アイコンが設定された場合
    if Value <> nil then
      FIcon.Assign(Value)
    // アイコンがクリア(削除)された場合
    else
    begin
      FIcon.ReleaseHandle;
      FIcon.Handle := 0;
{=====================================
2000.01.25 OwnerForm.Icon, Appliction.Icon で代替可能なため非表示化はしない
      // アイコンを非表示にするため、VisibleプロパティをFalseに設定
      Visible := False;
======================================}
    end;
  end;
end;

procedure TTrayIcon.SetLBPopupMenu(Value: TPopupMenu);
begin
  if Value <> FLBPopupMenu then
    FLBPopupMenu := Value;
  if FLBPopupMenu <> nil then
    Value.FreeNotification(Self);
end;

procedure TTrayIcon.SetRBPopupMenu(Value: TPopupMenu);
begin
  if Value <> FRBPopupMenu then
    FRBPopupMenu := Value;
  if FRBPopupMenu <> nil then
    Value.FreeNotification(Self);
end;

procedure TTrayIcon.SetTipHelp(Value: String);
begin
  if FTipHelp <> Copy(Value, 1, 62) then
  begin
    FTipHelp := Copy(Value, 1, 62);

    // デザイン時でない場合、チップヘルプの変更
    if not (csDesigning in ComponentState) then
      IconChange(Self);
  end;
end;

procedure TTrayIcon.SetTrayIcon(Value: TTrayIconMode);
begin
  // Shell_NotifyIcon用データ領域にプロパティの値を設定
  with NIconData^ do
  begin
    // アニメーション中でないか、手動アニメーション中の場合、
    // Iconプロパティのアイコンを設定
    if not FAnimated then
      hIcon := GetIconHandle
    else
      hIcon := AnimateThread.Icon.Handle;
    StrCopy(szTip, PChar(FTipHelp));
    if FtipHelp <> '' then
      uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP
    else
      uFlags := NIF_MESSAGE or NIF_ICON;
  end;

  case Value of
    tiAddIcon:
    begin
      // VisibleプロパティがTrueの場合、アイコンの登録
      if FVisible then
      begin
        // Shell_NotifyIcon用ウィンドウハンドルの(再)設定
        NIconData^.Wnd := CallbackWindow.Handle;
        if not Shell_NotifyIcon(NIM_ADD, NIconData) then
          raise ENotifyIconError.Create(NotifyIconErrMessage);
        IconRegisted := True;
      end;
    end;
    tiModifyIcon:
    begin
      if not Shell_NotifyIcon(NIM_MODIFY, NIconData) then
        raise ENotifyIconError.Create(NotifyIconErrMessage);
    end;
    tiDeleteIcon:
    begin
      Shell_NotifyIcon(NIM_DELETE, NIconData);
      IconRegisted := False;
    end;
  end;
end;

function TTrayIcon.GetIconHandle: THandle;
begin
  Result := FIcon.Handle;
  if Result = 0 then
  begin
    if Owner is TForm then
      Result := TForm(Owner).Icon.Handle;
    if Result = 0 then
      Result := Application.Icon.Handle;
  end;
end;

procedure TTrayIcon.SetVisible(Value: Boolean);
begin
  if Value <> FVisible then
  begin
    // 2001/01/25 Iconプロパティがなければ OwnerForm や Application を利用
    if GetIconHandle <> 0 then
      FVisible := Value
    else
      FVisible := False;

    // デザイン時でなく、コンポーネントをロード中でない場合、表示・非表示の切替え
    if not (csDesigning in ComponentState)
      and not (csLoading in ComponentState) then
    begin
      // 非表示→表示へ切替えた場合
      if FVisible then
        SetTrayIcon(tiAddIcon)
      // 表示→非表示へ切替えた場合
      else if IconRegisted then
        SetTrayIcon(tiDeleteIcon);
    end;
  end;
end;

constructor TSingleClick.Create;
begin
  inherited Create(False);

  // Executeメソッド終了後、TSingleClickスレッドクラスの自動破棄設定
  FreeOnterminate := True;
end;

procedure TSingleClick.Execute;
begin
  // シングルクリックの判定時間中、スレッドの停止
  Sleep(GetDoubleClickTime + 50);
end;

constructor TTrayIconAnimate.Create(AOwner: TTrayIcon);
begin
  inherited Create(True);

  // スレッド所有TrayIconコンポーネントの設定
  Owner := AOwner;
  // アニメーションフレームの初期化
  AnimateFrame := 0;
  // アニメーションアイコン用アイコンデータ領域確保
  Icon := TIcon.Create;
end;

destructor TTrayIconAnimate.Destroy;
begin
  // アニメーションアイコン用アイコンデータ領域の解放
  Icon.Free;

  inherited Destroy;
end;

procedure TTrayIconAnimate.Execute;
begin
  while not Terminated do
  begin
    if Owner.FAnimated then
    begin
      // AnimateIconsの内容が変更され、次に表示するアイコンがなくなった場合
      // 最初のアイコンに戻る
      if AnimateFrame > (Owner.FAnimateIcons.Count - 1) then
        AnimateFrame := 0;

      // アイコンの変更
      Owner.FAnimateIcons.GetIcon(AnimateFrame, Icon);
      // トレイにアイコンが表示されている場合、アイコンの反映
      if Owner.IconRegisted then
      begin
        with Owner.NIconData^ do
        begin
          hIcon := Icon.Handle;
          StrCopy(szTip, PChar(Owner.FTipHelp));
          if Owner.FTipHelp <> '' then
            uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP
          else
            uFlags := NIF_MESSAGE or NIF_ICON;
        end;
        Shell_NotifyIcon(NIM_MODIFY, Owner.NIconData);
      end;

      // 次に表示するアイコンのフレーム設定
      if AnimateFrame < (Owner.FAnimateIcons.Count - 1) then
        Inc(AnimateFrame)
      else
        AnimateFrame := 0;

      // アニメーションモードが自動の場合、指定されたミリ秒だけスレッドを停止
      if Owner.AnimateMode = amAutomatic then
        Sleep(Owner.FAnimateRate)
      else
        Suspend;
    end
    else
    begin
      AnimateFrame := 0;
      Suspend;
    end;
  end;
end;

procedure TCallbackWindow.CallbackWndProc(var Msg: TMessage);
var
  cursorpos: TPoint;
  objindex: Integer;
begin
  // TTrayIconオブジェクトのインデックス位置の設定
  objindex := IconIDList.IndexOf(IntToStr(Msg.wParam));
  if objindex >= 0 then
  begin
    FOwner := TTrayIcon(IconIDList.Objects[objindex]);
    // EnabledプロパティがFalseの場合、直にプロシージャから抜け出す
    if not FOwner.FEnabled then
      Exit;
  end
  else
    Exit;

  // マウスカーソルの現在位置取得
  GetCursorPos(cursorpos);

  // マウスのメッセージにより処理分岐
  case Msg.lParam of
    // アイコン上の通過時
    WM_MOUSEMOVE:
    begin
      if Assigned(FOwner.OnMouseMove) then
        FOwner.OnMouseMove(FOwner, [], cursorpos.X, cursorpos.Y);
    end;
    // 左ボタンのダウン時
    WM_LBUTTONDOWN:
    begin
      // 左ボタンにポップアップメニューを割り当てて、AutoPopupがTrueの場合
      if Assigned(FOwner.LBPopupMenu) and FOwner.AutoPopup then
      begin
        if FOwner.Owner is TForm then
        begin
          SetForegroundWindow(TForm(FOwner.Owner).Handle);
          Application.ProcessMessages;
        end;
        FOwner.LBPopupMenu.Popup(cursorpos.X, cursorpos.Y);
      end
      else if Assigned(FOwner.OnMouseDown) then
        FOwner.OnMouseDown(FOwner, mbLeft, [ssLeft], cursorpos.X, cursorpos.Y);
    end;
    // 左ボタンのアップ時
    WM_LBUTTONUP:
    begin
      if Assigned(FOwner.OnMouseUp) then
        FOwner.OnMouseUp(FOwner, mbLeft, [ssLeft], cursorpos.X, cursorpos.Y)
      else if Assigned(FOwner.OnClick) then
      begin
        if not FOwner.SingleClickExec then
        begin
          FOwner.SingleClickExec := True;
          with TSingleClick.Create do
            OnTerminate := OnClick;
        end
        else
        begin
          FOwner.SingleClickExec := False;
        end;
      end
      else
        FOwner.SingleClickExec := False;
    end;
    // 左ボタンのダブルクリック時
    WM_LBUTTONDBLCLK:
    begin
      FOwner.SingleClickExec := True;
      if Assigned(FOwner.OnDblClick) then
        FOwner.OnDblClick(FOwner);
    end;
    // 中ボタンのダウン時
    WM_MBUTTONDOWN:
    begin
      if Assigned(FOwner.OnMouseDown) then
        FOwner.OnMouseDown(FOwner, mbMiddle, [ssMiddle],
          cursorpos.X, cursorpos.Y);
    end;
    // 中ボタンのアップ時
    WM_MBUTTONUP:
    begin
      if Assigned(FOwner.OnMouseUp) then
        FOwner.OnMouseUp(FOwner, mbMiddle, [ssMiddle],
          cursorpos.X, cursorpos.Y);
    end;
    // 右ボタンのダウン時
    WM_RBUTTONDOWN:
    begin
      // 右ボタンにポップアップメニューを割り当てて、AutoPopupがTrueの場合
      if Assigned(FOwner.RBPopupMenu) and FOwner.AutoPopup then
      begin
        if FOwner.Owner is TForm then
        begin
          SetForegroundWindow(TForm(FOwner.Owner).Handle);
          Application.ProcessMessages;
        end;
        FOwner.RBPopupMenu.Popup(cursorpos.X, cursorpos.Y);
      end
      else if Assigned(FOwner.OnMouseDown) then
        FOwner.OnMouseDown(FOwner, mbRight, [ssRight],
          cursorpos.X, cursorpos.Y);
    end;
    // 右ボタンのアップ時
    WM_RBUTTONUP:
    begin
      if Assigned(FOwner.OnMouseUp) then
        FOwner.OnMouseUp(FOwner, mbRight, [ssRight],
          cursorpos.X, cursorpos.Y);
    end;
  end;
end;

procedure TCallbackWindow.OnClick(Sender: TObject);
begin
  if Assigned(FOwner.OnClick) and FOwner.SingleClickExec then
    FOwner.OnClick(FOwner);
  FOwner.SingleClickExec := False;
end;

procedure Register;
begin
  RegisterComponents('Win32', [TTrayIcon]);
end;

initialization
  // Shell_NotifyIcon用非表示ウィンドウクラスの初期化
  CallbackWindow := nil;

  // Shell_NotifyIcon用Icon IDリストの生成
  IconIDList := TStringList.Create;
  IconIDList.Sorted := False;

finalization
  // Shell_NotifyIcon用Icon IDリストの解放
  IconIDList.Free;

end.

