Problem mit Hook einer Komponente (Anzeigen eines Menüs)

[franz]

Habe es jetzt rausgefunden.
Man muss “TApplication.HookMainWindow” verwenden.

Allerdings gibt es jetzt wieder ein neues Problem. Wenn die Komponente verwendet wird und Delphi beendet wird, stürzt Delphi ab.

Vielleicht kann mir jemand weiterhelfen. Ich vermute, dass es an dem WindowHook liegt. Habe schon sehr viel probiert aber den Fehler nicht gefunden.

Delphi-Quellcode:

unit FJFShellTrayIcon;

interface

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

const
  WM_ICONTRAY = WM_USER + 1;

type
  TFJFShellTrayIcon = class(TComponent)
  private
    { Private-Deklarationen }
    FPopupMenu: TPopupMenu;
    FEnabled:   Boolean;
    FIcon:      TIcon;
    FTipText:   String;
    procedure SetIcon(NewIcon: TIcon);
    procedure SetTipText(NewText: String);
    procedure SetPopupMenu(NewPopupMenu: TPopupMenu);
  protected
    NotifyIconData: TNotifyIconData;
    OldWndProc, NewWndProc: Pointer;
    function  HookAppProc(var Msg: TMessage): Boolean;
    procedure HookForm;
    procedure UnhookForm;
    procedure HookFormProc(var Msg: TMessage);
  public
    { Public-Deklarationen }
    procedure Enable;
    procedure Execute;
    procedure UpdateTrayIcon;
    procedure Disable;
    procedure Show;
    procedure Hide;
  published
    { Published-Deklarationen }
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    property Icon: TIcon
        read FIcon write SetIcon;
    property TipText: String
        read FTipText write SetTipText;
    property PopupMenu: TPopupMenu
        read FPopupMenu write SetPopupMenu;
  end;

procedure Register;

implementation
{$R *.dcr}

procedure Register;
begin
  RegisterComponents('FJF', [TFJFShellTrayIcon]);
end;

constructor TFJFShellTrayIcon.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FEnabled := false;
  FIcon := TIcon.Create;
  FIcon.Assign(Application.Icon);
  FTipText  := Application.Title;

  Application.HookMainWindow(HookAppProc);
  if Owner is TWinControl then
     HookForm;
end;

destructor TFJFShellTrayIcon.Destroy;
begin
  if FEnabled then
     Disable;
  Application.ProcessMessages;

  FIcon.Free;
  Application.ProcessMessages;

  if not (csDesigning in ComponentState) then
     begin
        Application.UnhookMainWindow(HookAppProc);
        if Owner is TWinControl then
           UnhookForm;
     end;

  inherited Destroy;
end;

procedure TFJFShellTrayIcon.SetIcon(NewIcon: TIcon);
begin
  FIcon.Assign(NewIcon);
end;

procedure TFJFShellTrayIcon.SetTipText(NewText: String);
begin
  FTipText := NewText;
  UpdateTrayIcon;
end;

procedure TFJFShellTrayIcon.SetPopupMenu(NewPopupMenu: TPopupMenu);
begin
  // mHookMenu  := NewPopupMenu;
  FPopupMenu := NewPopupMenu;
end;

procedure TFJFShellTrayIcon.Enable;
const
  cErrNoPopup = 'No PopupMenu available!';
begin
  if (FEnabled) then
     Exit;
  if not Assigned(FPopupMenu) then
     raise Exception.Create(cErrNoPopup);

  with NotifyIconData do
    begin
      FillChar(NotifyIconData,SizeOf(TNotifyIconData),0);
      cbSize := sizeof(TNotifyIconData);
      hIcon := FIcon.Handle;
      StrPCopy(szTip, FTipText);
      Wnd := (Owner as TForm).Handle;
      uCallbackMessage := WM_ICONTRAY;
      uID := 1;
      uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
    end;
  Shell_NotifyIcon(NIM_ADD, @NotifyIconData);
  FEnabled := true;
end;

procedure TFJFShellTrayIcon.Execute;
begin
  Enable;
end;

procedure TFJFShellTrayIcon.Hide;
begin
  Application.MainForm.Hide;
  Enable;
end;

procedure TFJFShellTrayIcon.UpdateTrayIcon;
begin
  if not FEnabled then
     Exit;

  with NotifyIconData do
    begin
      hIcon := FIcon.Handle;
      StrPCopy(szTip, FTipText);
      Wnd := (Owner as TForm).Handle;
      uCallbackMessage := WM_ICONTRAY;
      uID := 1;
      uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
      cbSize := sizeof(TNotifyIconData);
    end;
  Shell_NotifyIcon(NIM_MODIFY, @NotifyIconData);
end;

procedure TFJFShellTrayIcon.Disable;
begin
  if not FEnabled then
     Exit;
  Shell_NotifyIcon(NIM_DELETE, @NotifyIconData);
  FEnabled := false;
end;

procedure TFJFShellTrayIcon.Show;
begin
  Application.MainForm.Show;
  Disable;
end;

function TFJFShellTrayIcon.HookAppProc(var Msg: TMessage): Boolean;
begin
  Result := False;

  if Msg.Msg = WM_IconTray  then
     if Msg.LParam = WM_RBUTTONDOWN then
        FPopupMenu.Popup(Mouse.CursorPos.x,Mouse.CursorPos.y);
end;

procedure TFJFShellTrayIcon.HookForm;
begin
  if ((Owner as TWinControl) <> nil) and (not (csDesigning in ComponentState)) then
     begin
       OldWndProc := Pointer(GetWindowLong((Owner as TWinControl).Handle, GWL_WNDPROC));
       {$IFDEF DELPHI_6_UP}
       NewWndProc := Classes.MakeObjectInstance(HookFormProc);
       {$ELSE}
        NewWndProc := MakeObjectInstance(HookFormProc);
       {$ENDIF}
       SetWindowLong((Owner as TWinControl).Handle, GWL_WNDPROC, LongInt(NewWndProc));
     end;
end;

procedure TFJFShellTrayIcon.HookFormProc(var Msg: TMessage);
begin
  if Msg.Msg = WM_IconTray then
     if Msg.LParam = WM_RBUTTONDOWN then
        FPopupMenu.Popup(Mouse.CursorPos.x,Mouse.CursorPos.y);

  Msg.Result := CallWindowProc(OldWndProc, (Owner as TWinControl).Handle,
                  Msg.Msg, Msg.wParam, Msg.lParam);
end;

procedure TFJFShellTrayIcon.UnhookForm;
begin
  if ((Owner as TWinControl) <> nil) and (Assigned(OldWndProc)) then
     SetWindowLong((Owner as TWinControl).Handle, GWL_WNDPROC, LongInt(OldWndProc));

  if Assigned(NewWndProc) then
     {$IFDEF DELPHI_6_UP}
     Classes.FreeObjectInstance(NewWndProc);
     {$ELSE}
     FreeObjectInstance(NewWndProc);
     {$ENDIF}

  NewWndProc := nil;
  OldWndProc := nil;
end;

end.