WebSVN – delphiutils – Blame – /trunk/Delphi Code/QuerySystemMenu/QuerySystemMenu.pas

Rev	Author	Line No.	Line
41	daniel-mar	1	unit QuerySystemMenu;
		2
		3	(*
		4
		5	QuerySystemMenu.pas
58	daniel-mar	6	(C) 2010 - 2011 Daniel Marschall
41	daniel-mar	7
		8	*)
		9
58	daniel-mar	10	// WM_UNINITMENUPOPUP is not implemented in Win 95.
		11	{.$DEFINE USE_WM_UNINITMENUPOPUP}
		12
41	daniel-mar	13	interface
		14
42	daniel-mar	15	// TODO: DefWindowProc() verwenden?
		16
41	daniel-mar	17	uses
42	daniel-mar	18	Windows, WindowsCompat, Classes, SysUtils;
41	daniel-mar	19
		20	type
42	daniel-mar	21	TWndProcIntercept = class(TObject)
41	daniel-mar	22	private
		23	FHandle: HWnd;
		24	FPrevWndProc: LONG_PTR;
		25	MsgProcPointer: Pointer;
42	daniel-mar	26	FIsRegistered: boolean;
		27	function MsgProcVirtualCall(Handle: HWnd; Msg: UInt; WParam: Windows.WParam; LParam: Windows.LParam): LResult; stdcall;
		28	procedure RegisterCB;
		29	procedure UnregisterCB;
		30	protected
		31	function MsgProc(Handle: HWnd; Msg: UInt; WParam: Windows.WParam; LParam: Windows.LParam): LResult; virtual; stdcall;
41	daniel-mar	32	public
		33	constructor Create(AHandle: Hwnd);
		34	destructor Destroy; override;
42	daniel-mar	35	end;
		36
		37	TQueryMenu = class(TWndProcIntercept)
		38	private
		39	FOnMenuOpen: TNotifyEvent;
		40	FOnMenuClose: TNotifyEvent;
		41	FMenuOpened: boolean;
		42	protected
		43	function MsgProc(Handle: HWnd; Msg: UInt; WParam: Windows.WParam; LParam: Windows.LParam): LResult; override; stdcall;
41	daniel-mar	44	published
42	daniel-mar	45	property IsMenuOpened: boolean read FMenuOpened;
		46	property OnMenuOpen: TNotifyEvent read FOnMenuOpen write FOnMenuOpen;
		47	property OnMenuClose: TNotifyEvent read FOnMenuClose write FOnMenuClose;
		48	end;
		49
		50	TQuerySystemMenu = class(TWndProcIntercept)
		51	private
		52	FOnSystemMenuOpen: TNotifyEvent;
		53	FOnSystemMenuClose: TNotifyEvent;
		54	FSystemMenuOpened: boolean;
		55	protected
		56	function MsgProc(Handle: HWnd; Msg: UInt; WParam: Windows.WParam; LParam: Windows.LParam): LResult; override; stdcall;
		57	published
41	daniel-mar	58	property IsSystemMenuOpened: boolean read FSystemMenuOpened;
		59	property OnSystemMenuOpen: TNotifyEvent read FOnSystemMenuOpen write FOnSystemMenuOpen;
		60	property OnSystemMenuClose: TNotifyEvent read FOnSystemMenuClose write FOnSystemMenuClose;
		61	end;
		62
		63	implementation
		64
		65	uses
		66	Messages, MethodPtr;
		67
42	daniel-mar	68	{ TWndProcIntercept }
		69
		70	constructor TWndProcIntercept.Create(AHandle: Hwnd);
41	daniel-mar	71	begin
42	daniel-mar	72	FHandle := AHandle;
		73
		74	RegisterCB;
		75	end;
		76
		77	destructor TWndProcIntercept.Destroy;
		78	begin
		79	UnregisterCB;
		80
		81	inherited;
		82	end;
		83
		84	function TWndProcIntercept.MsgProc(Handle: HWnd; Msg: UInt;
		85	WParam: Windows.WParam; LParam: Windows.LParam): LResult;
		86	begin
46	daniel-mar	87	result := Windows.CallWindowProc(WindowsCompat.WNDPROC(FPrevWndProc), Handle, Msg, WParam, LParam)
42	daniel-mar	88	end;
		89
		90	function TWndProcIntercept.MsgProcVirtualCall(Handle: HWnd; Msg: UInt;
		91	WParam: Windows.WParam; LParam: Windows.LParam): LResult;
		92	begin
		93	// Virtual call
		94	result := MsgProc(Handle, Msg, WParam, LParam);
		95	end;
		96
		97	procedure TWndProcIntercept.RegisterCB;
		98	var
		99	f: TMethod;
		100	begin
		101	if FIsRegistered then exit;
		102	FIsRegistered := true;
		103
		104	FPrevWndProc := GetWindowLongPtr(FHandle, GWLP_WNDPROC);
		105
		106	f.Code := @TWndProcIntercept.MsgProcVirtualCall;
		107	f.Data := Self;
46	daniel-mar	108	MsgProcPointer := MethodPtr.MakeProcInstance(f);
42	daniel-mar	109
		110	// Problem: Kann es zu Komplikationen mit mehreren msg handlern kommen?
		111	// (Beim vermischten register+unregister !)
43	daniel-mar	112
		113	SetWindowLongPtr(FHandle, GWLP_WNDPROC, LONG_PTR(MsgProcPointer));
42	daniel-mar	114	end;
		115
		116	procedure TWndProcIntercept.UnregisterCB;
		117	begin
		118	if not FIsRegistered then exit;
		119	FIsRegistered := false;
		120
		121	SetWindowLongPtr(FHandle, GWLP_WNDPROC, FPrevWndProc);
		122
		123	FreeProcInstance(MsgProcPointer);
		124	end;
		125
		126	{ TQueryMenu }
		127
		128	function TQueryMenu.MsgProc(Handle: HWnd; Msg: UInt; WParam: Windows.WParam;
		129	LParam: Windows.LParam): LResult;
		130	begin
41	daniel-mar	131	if Msg = WM_INITMENUPOPUP then
		132	begin
42	daniel-mar	133	FMenuOpened := true;
		134	if Assigned(FOnMenuOpen) then
		135	begin
		136	FOnMenuOpen(Self);
		137	end;
		138	end;
		139	if Msg = WM_UNINITMENUPOPUP then
		140	begin
		141	FMenuOpened := false;
		142	if Assigned(FOnMenuClose) then
		143	begin
		144	FOnMenuClose(Self);
		145	end;
		146	end;
		147
		148	result := inherited MsgProc(Handle, Msg, WParam, LParam);
		149	end;
		150
		151	{ TQuerySystemMenu }
		152
		153	function TQuerySystemMenu.MsgProc(Handle: HWnd; Msg: UInt; WParam: Windows.WParam; LParam: Windows.LParam): LResult;
		154	begin
58	daniel-mar	155	{$IFDEF USE_WM_UNINITMENUPOPUP}
41	daniel-mar	156	if Msg = WM_UNINITMENUPOPUP then
58	daniel-mar	157	{$ELSE}
59	daniel-mar	158	// WM_INITMENUPOPUP wird ben�tigt, falls man z.B. direkt in das
		159	// MainMenu mit einem Klick wechselt.
		160	// TODO: Problem, wenn das System-Menu Untermen�-Punkte besitzt?
		161	if FSystemMenuOpened and ((Msg = WM_EXITMENULOOP)
		162	or (Msg = WM_INITMENUPOPUP)) then
58	daniel-mar	163	{$ENDIF}
41	daniel-mar	164	begin
58	daniel-mar	165	{$IFDEF USE_WM_UNINITMENUPOPUP}
41	daniel-mar	166	// if Cardinal(WParam) = GetSystemMenu(FHandle, False) then
		167	if HiWord(lParam) = MF_SYSMENU then
		168	begin
58	daniel-mar	169	{$ENDIF}
41	daniel-mar	170	FSystemMenuOpened := false;
		171	if Assigned(FOnSystemMenuClose) then
		172	begin
		173	FOnSystemMenuClose(Self);
		174	end;
58	daniel-mar	175	{$IFDEF USE_WM_UNINITMENUPOPUP}
41	daniel-mar	176	end;
58	daniel-mar	177	{$ENDIF}
41	daniel-mar	178	end;
		179
59	daniel-mar	180	// TODO bug: l�st bei evtl vorhandenen submenus �fters aus
		181	if Msg = WM_INITMENUPOPUP then
		182	begin
		183	// if Cardinal(WParam) = GetSystemMenu(FHandle, False) then
		184	if LongBool(HiWord(lParam)) then
		185	begin
		186	FSystemMenuOpened := true;
		187	if Assigned(FOnSystemMenuOpen) then
		188	begin
		189	FOnSystemMenuOpen(Self);
		190	end;
		191	end;
		192	end;
		193
42	daniel-mar	194	result := inherited MsgProc(Handle, Msg, WParam, LParam);
41	daniel-mar	195	end;
		196
		197	end.

Subversion Repositories delphiutils

delphiutils/trunk/Delphi Code/QuerySystemMenu/QuerySystemMenu.pas – Rev 59