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

[franz]

:gruebel: Hi,
ich habe eine Komponente geschrieben, die die jeweilige Anwendung in den System Tray „befördern“ soll.
Da das Programm dann nur noch als Symbol im Tray angezeigt wird, ist ein Menü notwendig, um es zu beenden.

Mit einem Hook habe ich versucht dieses anzuzeigen, wenn der Benutzer die rechte Maustaste drückt.

Der Hook funktioniert auch soweit, solange das Menü innerhalb einer Form angezeigt wird. Wenn aber auf das Symbol im Tray geklickt wird, passiert gar nichts.

Ich habe mal den gesamten Quelltext der Unit aufgelistet:

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;
    procedure HookCreate(Sender: TObject);
    procedure HookDestroy(Sender: TObject);
  public
    { Public-Deklarationen }
    procedure Enable;
    procedure Execute;
    procedure UpdateTrayIcon;
    procedure Disable;
    procedure Show;
    procedure Hide;
    procedure Icontray(var Msg: TMessage); message WM_ICONTRAY;
  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;
function  MouseHookProc(nCode: Integer; wParam: WPARAM; lParam: LPARAM): Integer; stdcall;

implementation
//{$R *.dcr}

var
  hMouseHook: HHOOK;
  mHookMenu:  TPopupMenu;

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

function MouseHookProc(nCode: Integer; wParam: WPARAM; lParam: LPARAM): Integer; stdcall;
begin
  if (wParam = WM_RBUTTONDOWN) then
     if Assigned(mHookMenu) then
        mHookMenu.Popup(Mouse.CursorPos.x,Mouse.CursorPos.y);
  Result := CallNextHookEx(hMouseHook,nCode,wParam,lParam);
end;

procedure TFJFShellTrayIcon.HookCreate(Sender: TObject);
begin
  hMouseHook := SetWindowsHookEx(WH_MOUSE,MouseHookProc,0,0);
  inherited;
end;

procedure TFJFShellTrayIcon.HookDestroy(Sender: TObject);
begin
  UnhookWindowsHookEx(hMouseHook);
  // inherited;
end;

constructor TFJFShellTrayIcon.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FEnabled := false;
  FIcon := TIcon.Create;
  FIcon.Assign(Application.Icon);
  FTipText  := Application.Title;
  (Owner as TForm).OnShow    := HookCreate;
  (Owner as TForm).OnDestroy := HookDestroy;
end;

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

  FIcon.Free;
  Application.ProcessMessages;

  inherited Destroy;
end;

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

procedure TFJFShellTrayIcon.SetTipText(NewText: String);
begin
  FTipText := NewText;
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
      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_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.Icontray(var Msg: TMessage);
var
  CursorPos : TPoint;
begin
  if Msg.lParam = WM_RBUTTONDOWN then
     begin
       GetCursorPos(CursorPos);
       FPopupMenu.Popup(CursorPos.x, CursorPos.y);
     end
  else
    inherited;
end;

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

end.

[Assarbad]

Das weist darauf hin, daß der Hook nicht global sondern nur lokal läuft. Ist er in einer DLL untergebracht?

[franz]

Hi,
nein der Hook ist nicht in einer Dll untergebracht. Er befindet sich direkt im Quelltext der Komponente.

Ehrlich gesagt, habe ich bisher noch nie mit Hooks gearbeitet - war nie nötig.

Das komische am Ganzen ist außerdem, dass wenn der Hook nur eine Signalton auslöst, dieser auch zu hören ist, wenn mit der rechten Maustaste auf das Tray Icon geklickt wird. :wall: Nur mit dem PopupMenu will es nicht klappen.

[negaH]

Du solltest dir erstmal die Möglichkeiten von Shell_NotifyIcon() und NotifyIconData.uCallbackMessage genauer anschauen, bevor du mit Hooks auf brachiale Weise versuchst dein Problem zu lösen.

Gruß Hagen

[franz]

:zwinker: @negaH,
danke dir. Werde es morgen gleich probieren.

[franz]

:oops: Sorry,
habe den Quelltext der Komponente schon vor einiger Zeit geschrieben. Heute habe ich festgestellt, dass „TNotifyIconData.uCallbackMessage“ bereits enthalten ist.

Steht ja auch im oben aufgeführten Source.

Noch einmal zu den Details:
1. Eine Komponente ist ein Element, das in der Komponentenpalette erscheint – ich weiß ja nicht, ob euch das klar ist.

2. Ich habe den Code zuerst in einem Projekt unter TForm geschrieben. Als dann alles funktionierte, habe ich diesen in die Komponente übertragen (Deshalb ist im oberen Source auch die Prozedur „IconTray“ enthalten).

Da die Komponente nicht auf „procedure IconTray(var Msg: TMessage); message WM_ICONTRAY;“ reagiert, habe ich es mit „Applicaton.OnMessage“ versucht, das aber nur lokal und nicht global geholfen hat.

Danach habe ich einen Weg gesucht „WndProc“ von „TForm“ zu überschreiben, hatte aber keinen Erfolg.

Deshalb habe ich es mit einem Hook versucht, der aber auch nicht funktioniert.

Wenn der Verwender der Komponente in „TForm“ die Prozedur „IconTray“ so aufnimmt, wie diese in der Komponente deklariert ist, funktioniert auch wieder alles.

[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.

[negaH]

Hi Franz,

Dein Denkansatz ist vollkommen verkehrt. Du setzt mit

Delphi-Quellcode:

 Wnd := (Owner as TForm).Handle;

das Fensterhandle das die wm_TrayIcon Messages bekommen soll auf das übergeordnete Form, warum ??
Suche mal nach AllocateHWnd() und benutze diese Funktion um deiner Komponente ein eigenes Fensterhandle mit eigener Messagefunktion zu geben. Damit entfällt das komplizierte Hooking das du versuchst.


Gruß Hagen

[franz]

:hello: Habe die Fehlerquelle jetzt herausgefunden.
Bei „Create“ muss man noch den Komponentenstatus abfragen.

Wer die Komponente habe will, kann sie sich downloaden (auch, wenn sie nicht viel kann).

[franz]

@negaH,

:oops: sorry, du hast schon Recht Deine Lösung ist besser.
Aber „AllocateHWnd()“ habe ich in meinen Dokumentationen nicht gefunden. Außerdem habe ich die vorige Antwort offline in der Annahme geschrieben, dass niemand geantwortet hat. Immerhin mit einer kleinen Änderung funktioniert es jetzt auch.