PopupMenu andersfarbig

[Hagen Reddmann]

<pre>

var
FHook: hHook = 0;
FAtom: TAtom = 0;<br>

function MenuWndProc(hWnd: hWnd; Msg: Integer; wParam: WParam; lParam: LParam): LResult; stdcall;<br>
// alle Messages eines TPopupMenu->Windows->Fensterhandle
var
PrevFunc: Pointer;
DC: hDC;
B: hBrush;
R: TRect;
begin
THandle(PrevFunc) := GetProp(hWnd, MakeIntAtom(FAtom));
case Msg of
wm_Paint:
begin
end;
wm_NCPaint:
begin
DC := GetWindowDC(hWnd);
if DC <> 0 then
try
GetWindowRect(hWnd, R);
OffsetRect(R, -R.Left, -R.Top);
B := CreateSolidBrush(ColorToRGB(clMenu));
try
// zeichne eine schwarzen 1 Pixel Rahmen um's PopupMenu
FrameRect(DC, R, GetStockObject(BLACK_BRUSH));
InflateRect(R, -1, -1);
FrameRect(DC, R, B);
InflateRect(R, -1, -1);
FrameRect(DC, R, B);
finally
DeleteObject(B);
end;
finally
ReleaseDC(hWnd, DC);
end;
Result := 0;
Exit;
end;
wm_NCDestroy, wm_Destroy:
begin
RemoveProp(hWnd, MakeIntAtom(FAtom)); // wichtig sonst leaks !
end;
end;
if PrevFunc <> nil then Result := CallWindowProc(PrevFunc, hWnd, Msg, wParam, lParam)
else Result := 0;
end;<br>

function CallWndProcHook(Code: Integer; wParam: WParam; lParam: LParam): LResult; stdcall;
var
PrevWndProc: THandle;
Style: Integer;
begin
if lParam <> 0 then
with PCWPStruct(lParam)^ do
begin
case Message of
// 1. Methode, dynamisches SubClassing !
wm_Create:
with PCreateStruct(lParam)^ do
if lpszClass = MakeIntResource(32768) then // ist eine #POPUP# class
begin
PrevWndProc := GetProp(hWnd, MakeIntResource(FAtom));
if (PrevWndProc = 0) and (GetWindowLong(hWnd, gwl_WndProc) <> Integer(@MenuWndProc)) then
begin
PrevWndProc := GetWindowLong(hWnd, gwl_WndProc);
SetProp(hWnd, MakeIntResource(FAtom), PrevWndProc);
SetWindowLong(hWnd, gwl_WndProc, Integer(@MenuWndProc));
end;
end;
end;
end;
Result := CallNextHookEx(FHook, Code, wParam, lParam);
end;<br>

initialization
FAtom := GlobalAddAtom(PChar(Format('POPUPMENUHOOK_PREVWNDP ROC_%0.8x', [MainThreadID])));
FHook := SetWindowsHookEx(WH_CALLWNDPROC, CallWndProcHook, 0, MainThreadID);
finalization
UnhookWindowsHookEx(FHook);
GlobalDeleteAtom(FAtom);
end.<br>

</pre>

Gruß Hage

[Hagen Reddmann]

So nun der Kommentar !
Obiger Code macht das was Du willst. Es installiert für JEDES TPopupMenu und das dazugehörige PopupMenu-Kontainer-Fensterhandle eine neue Fensterfunktion "MenuWndProc".
Diese Funktion gilt für JEDES TPopupMenu Deiner Anwendung. Dies selektiv zu gestalten ist sehr schwierig, da wir eben nicht wissen welche TPopupMenu Komponente die richtige ist. Intern könnte man im TPopupMenu.Popup() eine globale Variable auf dieses PopupMenu speichern, die dann im obigen Hook ausgewertet werden kann. Das ist kein Problem da das Popup Kontainerfenster erst IM TrackPopupMenu/ex() erstellt und wieder zerstört wird.
<br>
Eine ganz andere Alternative wäre: Du hast ja eh schon Benutzerdefinierte TmenuItems , richtig ?? Warum dann im OnPaint() nicht mit getWindowFromDC() das Fensterhandle ermittelt, von diesem mit GetWindowDC(..) denn Fenster -DC und dann obigen Code in wm_NCPaint einfach beim zeichnen des ERSTEN MenuItems ausgeführt.

Das würde dann den Rahmen des TPopupMenus überzeichnen, und wird obiger Code benutzt dann ist das so schnell das man kein Flackern mehr sehen dürfte. Natürlich ist obiger Hook-Ansatz auf den ersten Blick eleganter, aber Hook's sind Hook's und eigentlich nur fürs Debugging angedacht, sehr instabil, (nicht mein Code im Hook, sondern das Gesamtsystem aller Hook und deren Verwaltung durch's OS). Genauer: Ich traue niemals irgend einer solchen Hook-Lösung, auch wenn viele behaupten das wäre absolut sicher, und meine eiegenen Erfahrungen das auch bestätigen !!<br>

Gruß Hagen<br>

PS: Ich habe obigen Code so aus dem gedächtniss heraus gepostet, also keine Garantie das es funktioniert !! :

[Hagen Reddmann]

sorry, schon den ersten Fehler gefunden. In MenuWndProc->wm_NCDestroy,wm_Destroy muss VOR dem RemoveProp() noch SetWindowLong(hWnd, gwl_WndProc, Integer(PrevWndProc)); eingefügt werden. <b>das ist sehr sehr WICHTIG !</b>

Gruß Hage

[Mathias Simmack]

Aus´m Gedächtnis heraus? Hagen, meinen allergrößten Respekt davor. &lt;den Hut zieh&gt; So´n Rumgeschleime, wa´? )

Aber im Ernst: ich hab´ mich damit rumgeschlagen, aber ich hätte das wohl kaum hingekriegt. So schnell schon gar nicht. Ich hab´ schon im DF-Forum geschrieben, dass es sich jetzt rächt, dass ich um die Windows-Programmierung immer einen Bogen gemacht habe. ( Ich hab´ damals immer nur DOS-Pascal installiert.

Aber ich denke (auch wenn´s wie ´ne Entschuldigung klingt), das liegt zum Teil auch daran, dass ich das nicht beruflich mache. Ich hatte also immer nur in meiner Freizeit ... äh, Zeit zum Programmieren. Und selbst wenn, ich bin nicht sicher ob ich das beruflich machen möchte. Komisch, was? Aber ich habe vor kurzem eine Art Praktikum gemacht und war quasi der Aushilfs-Admin (Netzwerk kontrollieren, böse Teilnehmer, die im Netz surfen, aussperren). Das hat mir beinahe mehr Spaß gemacht. Wobei ich gestehen muss, ich hatte Zeit genug, nebenbei ein bisschen Delphi zu machen. Tja, aber leider ist dieses Praktikum vorbei.

Egal.
Hagen, ich steh in deiner Schuld.
Wie wär´s mit ´nem Whiskey? ;o)

Gruß und Danke,
Mathias

[Hagen Reddmann]

Nochmal als Präzisierung:<br>
Solche Hooks sind schlecht, da sie ja ALLE Messages/Ereigniss ebelauschen. Es ist IMMER besser gezielt auf EIN Ereigniss zu reagieren. Im Falle einer neuen TpopupMenu Komponente, würde ich also die Methode .Popup() abändern. So daß im TrackPopupMenu/ex() als Reseiver Window ein eigenes, anstatt der Borland TpopupMenuList, angegeben wird. Dieses eigene Reseiver Fenster reagiert im wm_InitMenuPopup, das VOR dem Sichtbarmachen eintrift, mit der obigen Installation/SubClassing von MenuWndproc(). Damit werden NUR die PopupMenus zu Deiner neuen TpopupMenu Komponente gezielt berücksichtigt.<br>
Das bedeutet aber auch das das SystemMenu eines Fensters noch den alten Style besitzt

Gruß Hage

[Hagen Reddmann]

Hi

Gesetzt den Fall ALLE Menus der Anwendung sollen das neue Style besitzten, also TPopupMenus, TMainMenus und SubPopups und das SystemMenu der Fenster, dann ist folgendes genau richtig:

<pre>

unit MNUHook;<br>

interface<br>

implementation<br>

uses Windows, Messages, Graphics, Classes, SysUtils;<br>

var
FHook: hHook = 0;
FAtom: TAtom = 0;<br>

function CallWndProcHook(Code: Integer; wParam: WParam; lParam: LParam): LResult; stdcall;<br>

function DoNCPaint(Wnd: hWnd): Boolean;
var
DC: hDC;
B: hBrush;
R: TRect;
begin
Result := False;
DC := GetWindowDC(Wnd);
if DC <> 0 then
try
GetWindowRect(Wnd, R);
OffsetRect(R, -R.Left, -R.Top);
B := CreateSolidBrush(ColorToRGB(clMenu));
try
// zeichne eine schwarzen 1 Pixel Rahmen um's PopupMenu
FrameRect(DC, R, GetStockObject(BLACK_BRUSH));
InflateRect(R, -1, -1);
FrameRect(DC, R, B);
InflateRect(R, -1, -1);
FrameRect(DC, R, B);
Result := True;
finally
DeleteObject(B);
end;
finally
ReleaseDC(Wnd, DC);
end;
end;<br>

procedure MarkWindowAsPopup(Wnd: hWnd);
begin
if IsWindow(Wnd) and (GetProp(Wnd, MakeIntResource(FAtom)) <> MainThreadID) then
SetProp(Wnd, MakeIntResource(FAtom), MainThreadID);
end;<br>

begin
if lParam <> 0 then
with PCWPStruct(lParam)^ do
begin
case Message of
wm_NCPaint:
if (GetProp(hWnd, MakeIntResource(FAtom)) = MainThreadID) and DoNCPaint(hWnd) then
begin
// normalerweise wird von der API-Help "gemeint" das die in Hooks übergebenen
// Messages NICHT verändert werden können. Folgendes beweist das Gegenteil.
Message := wm_Null;
Result := 0;
Exit;
end;
wm_NCDestroy, wm_Destroy:
if GetProp(hWnd, MakeIntResource(FAtom)) = MainThreadID then
RemoveProp(hWnd, MakeIntResource(FAtom));
wm_InitMenuPopup:
MarkWindowAsPopup(FindWindow(MakeIntResource(32768 ), nil));
wm_Create:
with PCreateStruct(lParam)^ do
if lpszClass = MakeIntResource(32768) then // ist eine #POPUP# class
MarkWindowAsPopup(hWnd);
end;
end;
Result := CallNextHookEx(FHook, Code, wParam, lParam);
end;<br>

initialization
FAtom := GlobalAddAtom(PChar(Format('POPUPMENU_IDENTIFY_%0. 8x', [MainThreadID])));
FHook := SetWindowsHookEx(WH_CALLWNDPROC, CallWndProcHook, 0, MainThreadID);
finalization
UnhookWindowsHookEx(FHook);
GlobalDeleteAtom(FAtom);
end.<br>

</pre>

Interessant ist es diese Unit im Benutzerpackage von delphi zu installieren, einfach mal probieren

gruß Hage

[Mathias Simmack]

Hagen, der Entwickler der XPMenü-Komponente (
http://www.shagrouni.com/
) sucht nach dieser Lösung. Von ihm habe ich ja auch die "alte" Flach-Mach-Routine (s. weiter oben). Vielleicht könntest du ihm das mailen?!

Cool is´ es ja. Ich hab´s schon eingebaut und so geschaltet, dass das flache Menü nur unter 9x/ME/NT/2000 benutzt wird. Unter XP ist´s Quatsch, denn da ist es ohnehin flach. )

Gruß,
Mathias

[Hagen Reddmann]

Jo, und nun ist die "Kacke am dampfen". Obiger Code funktioniert NICHT unter 2000/ME? mit seinen shit Animationen bzw. Fading. Also nochmal rangemacht und hier ist die endgueltige Version. Sie entfernt von ALLEN Popup's den Rahmen. Nun, der Entwickler der XP-Komponente kann diesen Code nutzen wenn er <br>
1.) meinen Namen reinschreibt<br>
2.) darauf Aufmerksam macht das ich KEINERLEI Garantien übernehme<br>
3.) seine Komponente KEINE kommerzielle ist, sondern kostenlose Shareware oder Freeware, am besten mit Sourcen ist.<br>
<br>
<pre>

unit DPLMisc;<br>

interface<br>

implementation<br>

uses Windows, Messages, Graphics, Classes, SysUtils;<br>

var
FHook: hHook = 0;<br>

function CallWndProcHook(Code: Integer; wParam: WParam; lParam: LParam): LResult; stdcall;<br>

procedure MenuNCPaint(Wnd: hWnd; DC: hDC; IsClient: Boolean);
var
D: hDC;
B: hBrush;
R: TRect;
P: TPoint;
begin
if DC = 0 then D := GetWindowDC(Wnd) else D := DC;
if D <> 0 then
try
B := CreateSolidBrush(ColorToRGB(clRed));
try
if IsClient then SetWindowOrgEx(D, 0, 0, @P);
SelectClipRgn(D, 0);
GetWindowRect(Wnd, R);
OffsetRect(R, -R.Left, -R.Top);
// ab hier kann im Bereich R gezeichnet werden, R = Bounds(0, 0, Width, Height);
FrameRect(D, R, B);
InflateRect(R, -1, -1);
FrameRect(D, R, B);
InflateRect(R, -1, -1);
FrameRect(D, R, B);
finally
if IsClient then SetWindowOrgEx(D, P.X, P.Y, @P);
DeleteObject(B);
end;
finally
if DC = 0 then ReleaseDC(Wnd, D);
end;
end;<br>

function IsPopupMenu(Wnd: hWnd): Boolean;
var // test ob Wnd ein PopupMenu Kontainer Window ist
N: array[0..8] of Char;
begin
Result := IsWindow(Wnd) and
((GetClassLong(Wnd, GCW_ATOM) = 32768) or
(StrLIComp(@N, '#32768', GetClassName(Wnd, @N, SizeOf(N))) = 0));
end;<br>

begin
Result := CallNextHookEx(FHook, Code, wParam, lParam);
if lParam <> 0 then
with PCWPStruct(lParam)^ do
case Message of
wm_PrintClient: // Win2000 sendet wm_Print & wm_PrintClient für Fading oder MenuAnimation
if IsPopupMenu(hWnd) then MenuNCPaint(hWnd, wParam, True);
wm_EraseBkGnd:
if IsPopupMenu(hWnd) then MenuNCPaint(hWnd, 0, False);
end;
end;<br>

initialization
FHook := SetWindowsHookEx(WH_CALLWNDPROC, CallWndProcHook, 0, MainThreadID);
finalization
UnhookWindowsHookEx(FHook);
end.<br>

</pre>

Gruß hage

[Mathias Simmack]

1.) wird er sicher<br>
2.) versteht sich von selbst, weil genug Gründe, warum´s nicht so ideal ist (Hooks) hast du ja geliefert<br>
3.) ist sie

Mathias

[Mathias Simmack]

Hallo Hagen,<br>
das mit dem "Problem" unter 2000 ist mir gar nicht aufgefallen. Aber ich hab´s mal getestet. Dann ist es wohl so, dass diese Nachricht "wm_ncpaint" nur dann gesendet wird, wenn du beispielsweise von einem Untermenü wieder rausgehst. Das war nämlich bei mir der Fall; <u>dann</u> wurde der flache Rahmen gemalt. Und sobald ich die Menüanimation gänzlich abgeschaltet hatte, ging ja alles wieder anstandslos.<br><br>
Da habe ich dann doch noch eine Frage an dich.<br><br>
Wenn ich weiterhin nur <b>mein</b> Popup-Menü in diesem flachen Stil zeichnen will, dann müsste ich also schon bei deinem ersten Code-Posting bleiben (also: benutzerdefinierte "MenuWndProc"). Um dann aber die besagten Animationen von Win2000 und ME zu berücksichtigen: wo müssten dann "wm_printclient" und "wm_erasebkgnd" rein? Nach wie vor in die "CallWndProc" oder in dem Fall dann auch in die eigene Routine? Wie gesagt, ich möchte das Systemmenü eigentlich nicht ändern.<br><br>Mathias

[Hagen Reddmann]

Ich würde es so lassen und nur IsPopupMenu() abändern in

<pre>
var
HookActive: Integer = 0;<br>

......<br>

function IsPopupMenu(Wnd: hWnd): Boolean;
var // test ob Wnd ein PopupMenu Kontainer Window ist
N: array[0..8] of Char;
begin
Result := (HookActive > 0) and IsWindow(Wnd) and
((GetClassLong(Wnd, GCW_ATOM) = 32768) or
(StrLIComp(@N, '#32768', GetClassName(Wnd, @N, SizeOf(N))) = 0));
end;<br>

.......<br>

Im TMyPopupMenu.Popup() dann:<br>
<br>
Inc(HookActive);
try
inherited Popup(..);
// oder
TrackPopupMenu(..);
finally
Dec(HookActive);
end;<br>

</pre>

Das dürfte gut funktionieren, und falls ALLE Menus das gleiche Aussehen bekommen sollen, einfach HookActive auf 1 setzen.

Gruß Hage

[Mathias Simmack]

Aha. Na ja, in meinem Fall kommt eben noch dazu, dass ich die Farben von meinem Popup-Menü auch ändern kann. Zur Laufzeit des Programms. Deswegen wollte ich das Systemmenü beispielsweise unverändert lassen, weil das (abhängig von den aktiven Farben) auch den entsprechenden Rand hatte. )

Mathias

[Mathias Simmack]

So, ich habe mal Hagens Routinen zu einer Unit zusammengefasst. Ich muss dazu sagen, dass es ein bisschen "doppelt gemoppelt" ist, aber leider nötig war, weil die Funktion für animierte Menüs unter 9x Probleme verursacht. Jedenfalls bei mir.<br><br>
Außerdem habe ich festgestellt, dass es auch unter XP klappt - zumindest in der klassischen Ansicht. Deshalb ist noch eine zweite Unit bei, die darauf Rücksicht nimmt.<br><br>
Das komplette Projekt samt Sourcen gibt´s für alle Experimentierfreudigen hier:
http://www.reihe5.de/markus/flatmenu.zip<br><br>
Bedanken könnt ihr euch bei Hagen und bei den Jedis, von denen die XP-Prüffunktionen stammen. Das Feedback solltet ihr vielleicht besser an mich schicken, Hagen hat schon genug zu tun. Und wenn´s der Webmaster irgendwann erlaubt, könnte man das ganze Beispiel ja in den Download-Ordner übernehmen. Getestet wurde das ganze unter Win98/2000/XP und NT (letzteres allerdings nicht von mir).<br><br>
Mathias