请问：双击托盘区的时钟，如何弹出自己的程序？(50分)

//====================================================
// 模块功能：系统托盘操作的组件
// 模块作者：未知
// 修改整理：绿荫网络 Lvyin.net
// 最近更新：
// 适合版本：D4,D5,D6
//====================================================

unit TrayBarIcon;

interface

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

const
  //自定义用户信息
  WM_TRAYNOTIFY = WM_USER + 1024;
  IconID = 1;

type
  TCycleEvent = procedure(Sender: TObject; Current: Integer) of object;
  TMainFormMinimizeEvent = procedure(Sender: TObject; var GotoTray: Boolean) of object;

  TTrayIcon = class(TComponent)
  private
    FEnabled: Boolean;
    FIcon: TIcon;
    FIconVisible: Boolean;
    FHint: String;
    FShowHint: Boolean;
    FPopupMenu: TPopupMenu;
    FLeftPopup: Boolean;
    FOnClick,
    FOnDblClick: TNotifyEvent;
    FOnCycle: TCycleEvent;
    FOnMouseDown,
    FOnMouseUp: TMouseEvent;
    FOnMouseMove: TMouseMoveEvent;
    FStartMinimized: Boolean;
    FMinimizeToTray: Boolean;
    HasShown: Boolean;
    FClicked: Boolean;
    CycleTimer: TTimer;           // 图标变换
    FDesignPreview: Boolean;
    SettingPreview: Boolean;
    FIconList: TImageList;
    FCycleIcons: Boolean;
    FCycleInterval: Cardinal;
    IconIndex: Integer;           // 当前图标索引
    OldAppProc, NewAppProc: Pointer;   // 过程变量
    procedure SetCycleIcons(Value: Boolean);
    procedure SetDesignPreview(Value: Boolean);
    procedure SetCycleInterval(Value: Cardinal);
    procedure TimerCycle(Sender: TObject);
    procedure HandleIconMessage(var Msg: TMessage);
    function InitIcon: Boolean;
    procedure SetIcon(Value: TIcon);
    procedure SetIconVisible(Value: Boolean);
    procedure SetHint(Value: String);
    procedure SetShowHint(Value: Boolean);
    procedure PopupAtCursor;
    procedure HookApp;
    procedure UnhookApp;
    procedure HookAppProc(var Message: TMessage);
  protected
    IconData: TNotifyIconData;    // 系统托盘图标的数据结构
    procedure Loaded; override;
    function ShowIcon: Boolean; virtual;
    function HideIcon: Boolean; virtual;
    function ModifyIcon: Boolean; virtual;
    procedure Click; dynamic;
    procedure DblClick; dynamic;
    procedure CycleIcon; dynamic;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); dynamic;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); dynamic;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); dynamic;
    procedure DoMinimizeToTray; dynamic;
    procedure Notification(AComponent: TComponent; Operation: TOperation);
      override;
  public
    property Handle: HWND read IconData.wnd;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ShowMainForm;
    procedure HideMainForm;
    procedure Refresh;
  published
    // 属性操作:
    property DesignPreview: Boolean read FDesignPreview
      write SetDesignPreview default False;
    property IconList: TImageList read FIconList write FIconList;
    property CycleIcons: Boolean read FCycleIcons write SetCycleIcons
      default False;
    property CycleInterval: Cardinal read FCycleInterval
      write SetCycleInterval;
    property Enabled: Boolean read FEnabled write FEnabled default True;
    property Hint: String read FHint write SetHint;
    property ShowHint: Boolean read FShowHint write SetShowHint;
    property Icon: TIcon read FIcon write SetIcon stored True;
    property IconVisible: Boolean read FIconVisible write SetIconVisible
      default True;
    property PopupMenu: TPopupMenu read FPopupMenu write FPopupMenu;
    property LeftPopup: Boolean read FLeftPopup write FLeftPopup
      default False;
    property StartMinimized: Boolean read FStartMinimized write FStartMinimized
      default False;         // 程序开始运行时最小化?
    property MinimizeToTray: Boolean read FMinimizeToTray write FMinimizeToTray
      default False;         // 程序最小化时是否自动显示图标?
    // 方法:
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
    property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
    property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
    property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
    property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
    property OnCycle: TCycleEvent read FOnCycle write FOnCycle;
  end;

procedure Register;

implementation

constructor TTrayIcon.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FIconVisible := True;
  FEnabled := True;
  HasShown := False;
  SettingPreview := False;

  FIcon := TIcon.Create;
  IconData.cbSize := SizeOf(TNotifyIconData);
  // 设置托盘图标回调函数
  IconData.wnd := AllocateHWnd(HandleIconMessage);
  // 设置图标ID
  IconData.uId := IconID;
  // 设置 图标，消息句柄，提示
  IconData.uFlags := NIF_ICON + NIF_MESSAGE + NIF_TIP;
  // 当鼠标在图标上有动作时发出的消息
  IconData.uCallbackMessage := WM_TRAYNOTIFY;

  CycleTimer := TTimer.Create(Self);
  CycleTimer.Enabled := False;
  CycleTimer.Interval := FCycleInterval;
  CycleTimer.OnTimer := TimerCycle;

  if not (csDesigning in ComponentState) then
    HookApp;
end;


destructor TTrayIcon.Destroy;
begin
  SetIconVisible(False);     // 移去系统托盘图标
  FIcon.Free;
  DeallocateHWnd(IconData.Wnd);
  CycleTimer.Free;

  if not (csDesigning in ComponentState) then
    UnhookApp;
  inherited Destroy;
end;


procedure TTrayIcon.Loaded;
begin
  inherited Loaded;
  SetIconVisible(FIconVisible);
  if (StartMinimized) and not (csDesigning in ComponentState) then
  begin
    Application.ShowMainForm := False;
    ShowWindow(Application.Handle, SW_HIDE);
  end;
  ModifyIcon;
end;


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

procedure TTrayIcon.HookApp;
begin
  OldAppProc := Pointer(GetWindowLong(Application.Handle, GWL_WNDPROC));
  NewAppProc := MakeObjectInstance(HookAppProc);
  SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(NewAppProc));
end;


procedure TTrayIcon.UnhookApp;
begin
  if Assigned(OldAppProc) then
    SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(OldAppProc));
  if Assigned(NewAppProc) then
    FreeObjectInstance(NewAppProc);
  NewAppProc := nil;
  OldAppProc := nil;
end;

procedure TTrayIcon.HookAppProc(var Message: TMessage);
begin
  with Message do
  begin
    case Msg of
      WM_SIZE:
        if wParam = SIZE_MINIMIZED then
        begin
          if FMinimizeToTray then
            DoMinimizeToTray;
        end;
    end;

    Result := CallWindowProc(OldAppProc, Application.Handle, Msg, wParam, lParam);
  end;
end;

procedure TTrayIcon.HandleIconMessage(var Msg: 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;
  M: TMenuItem;
begin
  if Msg.Msg = WM_TRAYNOTIFY then
  begin
    case Msg.lParam of

    WM_MOUSEMOVE:
      if FEnabled then
      begin
        Shift := ShiftState;
        GetCursorPos(Pt);
        MouseMove(Shift, Pt.X, Pt.Y);
      end;

    WM_LBUTTONDOWN:
      if FEnabled then
      begin
        Shift := ShiftState + [ssLeft];
        GetCursorPos(Pt);
        MouseDown(mbLeft, Shift, Pt.X, Pt.Y);
        FClicked := True;
        if FLeftPopup then
          PopupAtCursor;
      end;

    WM_RBUTTONDOWN:
      if FEnabled then
      begin
        Shift := ShiftState + [ssRight];
        GetCursorPos(Pt);
        MouseDown(mbRight, Shift, Pt.X, Pt.Y);
        PopupAtCursor;
      end;

    WM_MBUTTONDOWN:
      if FEnabled then
      begin
        Shift := ShiftState + [ssMiddle];
        GetCursorPos(Pt);
        MouseDown(mbMiddle, Shift, Pt.X, Pt.Y);
      end;

    WM_LBUTTONUP:
      if FEnabled then
      begin
        Shift := ShiftState + [ssLeft];
        GetCursorPos(Pt);
        if FClicked then
        begin
          FClicked := False;
          Click;
        end;
        MouseUp(mbLeft, Shift, Pt.X, Pt.Y);
      end;

    WM_RBUTTONUP:
      if FEnabled then
      begin
        Shift := ShiftState + [ssRight];
        GetCursorPos(Pt);
        MouseUp(mbRight, Shift, Pt.X, Pt.Y);
      end;

    WM_MBUTTONUP:
      if FEnabled then
      begin
        Shift := ShiftState + [ssMiddle];
        GetCursorPos(Pt);
        MouseUp(mbMiddle, Shift, Pt.X, Pt.Y);
      end;

    WM_LBUTTONDBLCLK:
      if FEnabled then
      begin
        DblClick;
        M := nil;
        if Assigned(FPopupMenu) then
          if (FPopupMenu.AutoPopup) and (not FLeftPopup) then
            for I := PopupMenu.Items.Count -1 downto 0 do
            begin
              if PopupMenu.Items[I].Default then
                M := PopupMenu.Items[I];
            end;
        if M <> nil then
          M.Click;
      end;
    end;
  end

  else
    case Msg.Msg of
      WM_QUERYENDSESSION: Msg.Result := 1;
    else
      Msg.Result := DefWindowProc(IconData.Wnd, Msg.Msg, Msg.wParam, Msg.lParam);
    end;
end;


procedure TTrayIcon.SetIcon(Value: TIcon);
begin
  // 设置图标
  FIcon.Assign(Value);
  ModifyIcon;
end;


procedure TTrayIcon.SetIconVisible(Value: Boolean);
begin
  // 设置是否显示图标
  if Value then
    ShowIcon
  else
    HideIcon;
end;


procedure TTrayIcon.SetDesignPreview(Value: Boolean);
begin
  // 设置是否预览图标
  FDesignPreview := Value;
  SettingPreview := True;
  SetIconVisible(Value);
  SettingPreview := False;
end;


procedure TTrayIcon.SetCycleIcons(Value: Boolean);
begin
  // 设置是否动态显示图标
  FCycleIcons := Value;
  if Value then
    IconIndex := 0;
  CycleTimer.Enabled := Value;
end;


procedure TTrayIcon.SetCycleInterval(Value: Cardinal);
begin
  // 设置动态图标的更换时间间隔
  FCycleInterval := Value;
  CycleTimer.Interval := FCycleInterval;
end;


procedure TTrayIcon.SetHint(Value: String);
begin
  // 设置要显示的提示信息
  FHint := Value;
  ModifyIcon;
end;


procedure TTrayIcon.SetShowHint(Value: Boolean);
begin
  // 设置是否显示提示
  FShowHint := Value;
  ModifyIcon;
end;


function TTrayIcon.InitIcon: Boolean;
var
  ok: Boolean;
begin
  // 初始化图标
  Result := False;
  ok := True;
  if (csDesigning in ComponentState) then
  begin
    if SettingPreview then
      ok := True
    else
      ok := FDesignPreview
  end;

  if ok then
  begin
    IconData.hIcon := FIcon.Handle;
    if (FHint <> '') and (FShowHint) then
      StrLCopy(IconData.szTip, PChar(FHint), SizeOf(IconData.szTip))
    else
      IconData.szTip := '';
    Result := True;
  end;
end;


function TTrayIcon.ShowIcon: Boolean;
begin
  Result := False;
  // 如果没有设置图标预览，则显示图标
  if not SettingPreview then
    FIconVisible := True;
  if (csDesigning in ComponentState) then
  begin
    if SettingPreview then
      if InitIcon then
        Result := Shell_NotifyIcon(NIM_ADD, @IconData);
  end
  else
  if InitIcon then
    Result := Shell_NotifyIcon(NIM_ADD, @IconData);
end;


function TTrayIcon.HideIcon: Boolean;
begin
  Result := False;
  // 如果没有设置图标预览，则隐藏图标
  if not SettingPreview then
    FIconVisible := False;
  if (csDesigning in ComponentState)then
  begin
    if SettingPreview then
      if InitIcon then
        Result := Shell_NotifyIcon(NIM_DELETE, @IconData);
  end
  else
  if InitIcon then
    Result := Shell_NotifyIcon(NIM_DELETE, @IconData);
end;


function TTrayIcon.ModifyIcon: Boolean;
begin
  Result := False;
  // 设置托盘图标操作
  if InitIcon then
    Result := Shell_NotifyIcon(NIM_MODIFY, @IconData);
end;


procedure TTrayIcon.TimerCycle(Sender: TObject);
begin
  // 循环更改图标
  if Assigned(FIconList) then
  begin
    FIconList.GetIcon(IconIndex, FIcon);
    CycleIcon;
    ModifyIcon;

    if IconIndex < FIconList.Count-1 then
      Inc(IconIndex)
    else
      IconIndex := 0;
  end;
end;


procedure TTrayIcon.ShowMainForm;
var
  I, J: Integer;
begin
  // 恢复程序
  ShowWindow(Application.Handle, SW_RESTORE);
  // 恢复主窗体
  ShowWindow(Application.MainForm.Handle, SW_RESTORE);

  if not HasShown then
  begin
    for I := 0 to Application.MainForm.ComponentCount -1 do
      if Application.MainForm.Components[I] is TWinControl then
        with Application.MainForm.Components[I] as TWinControl do
          if Visible then
          begin
            ShowWindow(Handle, SW_SHOWDEFAULT);
            for J := 0 to ComponentCount -1 do
              if Components[J] is TWinControl then
                ShowWindow((Components[J] as TWinControl).Handle, SW_SHOWDEFAULT);
          end;
    HasShown := True;
  end;
end;


procedure TTrayIcon.HideMainForm;
begin
  //显示程序
  ShowWindow(Application.Handle, SW_HIDE);
  //显示主窗体
  ShowWindow(Application.MainForm.Handle, SW_HIDE);
end;


procedure TTrayIcon.Refresh;
begin
  ModifyIcon;
end;


procedure TTrayIcon.PopupAtCursor;
var
  CursorPos: TPoint;
begin
  // 如果指定了弹出菜单，则
  if Assigned(PopupMenu) then
    // 如果是设置了自动弹出，则
    if PopupMenu.AutoPopup then
      if GetCursorPos(CursorPos) then
      begin
        // 让应用程序处理当前的消息
        Application.ProcessMessages;
        // 设应用程序主窗体为当前焦点窗体
        SetForegroundWindow(Application.MainForm.Handle);
        PopupMenu.PopupComponent := Self;
        // 显示弹出菜单
        PopupMenu.Popup(CursorPos.X, CursorPos.Y);
        // 发出消息
        PostMessage(Application.MainForm.Handle, WM_NULL, 0, 0);
      end;
end;


procedure TTrayIcon.Click;
begin
  if Assigned(FOnClick) then
    FOnClick(Self);
end;


procedure TTrayIcon.DblClick;
begin
  if Assigned(FOnDblClick) then
    FOnDblClick(Self);
end;


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


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


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


procedure TTrayIcon.CycleIcon;
begin
  if Assigned(FOnCycle) then
    FOnCycle(Self, IconIndex);  //显示下一个图标
end;


procedure TTrayIcon.DoMinimizeToTray;
begin
  // 隐藏主窗体
  HideMainForm;
  // 显示图标
  IconVisible := True;
end;


procedure Register;
begin
  //注册到组件库中
  RegisterComponents('Lvyin.net', [TTrayIcon]);
end;

end.