Subversion Repositories delphiutils

Compare Revisions

Regard whitespace Rev 41 → Rev 42

/trunk/Delphi Code/QuerySystemMenu/WindowsCompat.pas
1,20 → 1,25
unit WindowsCompat;
 
// Ref: http://qc.embarcadero.com/wc/qcmain.aspx?d=48771
 
interface
 
uses
Windows;
 
// TODO: Wie definiert?
{$IF NOT DECLARED(GWLP_WNDPROC)}
const
GWLP_WNDPROC = -4;
{$IFEND}
 
{$IF NOT DECLARED(LONG_PTR)}
type
LONG_PTR = Pointer; // TODO: ?
LONG_PTR = Pointer; // TODO: Wie genau definiert?
{$IFEND}
 
{$IF NOT DECLARED(WNDPROC)}
type
WNDPROC = TFNWndProc; // TODO: ?
WNDPROC = TFNWndProc; // TODO: Wie genau definiert?
{$IFeND}
 
{$IF NOT DECLARED(GetWindowLongPtr)}
/trunk/Delphi Code/QuerySystemMenu/QuerySystemMenu.pas
9,23 → 9,49
 
interface
 
// TODO: DefWindowProc() verwenden?
 
uses
Windows, WindowsCompat, Classes;
Windows, WindowsCompat, Classes, SysUtils;
 
type
TQuerySystemMenu = class(TObject)
TWndProcIntercept = class(TObject)
private
FOnSystemMenuOpen: TNotifyEvent;
FOnSystemMenuClose: TNotifyEvent;
FSystemMenuOpened: boolean;
FHandle: HWnd;
FPrevWndProc: LONG_PTR;
MsgProcPointer: Pointer;
function MsgProc(Handle: HWnd; Msg: UInt; WParam: Windows.WParam; LParam: Windows.LParam): LResult; stdcall;
FIsRegistered: boolean;
function MsgProcVirtualCall(Handle: HWnd; Msg: UInt; WParam: Windows.WParam; LParam: Windows.LParam): LResult; stdcall;
procedure RegisterCB;
procedure UnregisterCB;
protected
function MsgProc(Handle: HWnd; Msg: UInt; WParam: Windows.WParam; LParam: Windows.LParam): LResult; virtual; stdcall;
public
constructor Create(AHandle: Hwnd);
destructor Destroy; override;
end;
 
TQueryMenu = class(TWndProcIntercept)
private
FOnMenuOpen: TNotifyEvent;
FOnMenuClose: TNotifyEvent;
FMenuOpened: boolean;
protected
function MsgProc(Handle: HWnd; Msg: UInt; WParam: Windows.WParam; LParam: Windows.LParam): LResult; override; stdcall;
published
property IsMenuOpened: boolean read FMenuOpened;
property OnMenuOpen: TNotifyEvent read FOnMenuOpen write FOnMenuOpen;
property OnMenuClose: TNotifyEvent read FOnMenuClose write FOnMenuClose;
end;
 
TQuerySystemMenu = class(TWndProcIntercept)
private
FOnSystemMenuOpen: TNotifyEvent;
FOnSystemMenuClose: TNotifyEvent;
FSystemMenuOpened: boolean;
protected
function MsgProc(Handle: HWnd; Msg: UInt; WParam: Windows.WParam; LParam: Windows.LParam): LResult; override; stdcall;
published
property IsSystemMenuOpened: boolean read FSystemMenuOpened;
property OnSystemMenuOpen: TNotifyEvent read FOnSystemMenuOpen write FOnSystemMenuOpen;
property OnSystemMenuClose: TNotifyEvent read FOnSystemMenuClose write FOnSystemMenuClose;
36,10 → 62,97
uses
Messages, MethodPtr;
 
function TQuerySystemMenu.MsgProc(Handle: HWnd; Msg: UInt; WParam: Windows.WParam; LParam: Windows.LParam): LResult; stdcall;
{ TWndProcIntercept }
 
constructor TWndProcIntercept.Create(AHandle: Hwnd);
begin
FHandle := AHandle;
 
RegisterCB;
end;
 
destructor TWndProcIntercept.Destroy;
begin
UnregisterCB;
 
inherited;
end;
 
function TWndProcIntercept.MsgProc(Handle: HWnd; Msg: UInt;
WParam: Windows.WParam; LParam: Windows.LParam): LResult;
begin
result := Windows.CallWindowProc(WNDPROC(FPrevWndProc), Handle, Msg, WParam, LParam)
end;
 
function TWndProcIntercept.MsgProcVirtualCall(Handle: HWnd; Msg: UInt;
WParam: Windows.WParam; LParam: Windows.LParam): LResult;
begin
// Virtual call
result := MsgProc(Handle, Msg, WParam, LParam);
end;
 
procedure TWndProcIntercept.RegisterCB;
var
f: TMethod;
begin
if FIsRegistered then exit;
FIsRegistered := true;
 
FPrevWndProc := GetWindowLongPtr(FHandle, GWLP_WNDPROC);
 
f.Code := @TWndProcIntercept.MsgProcVirtualCall;
f.Data := Self;
MsgProcPointer := MakeProcInstance(f);
 
// Problem: Kann es zu Komplikationen mit mehreren msg handlern kommen?
// (Beim vermischten register+unregister !)
SetWindowLongPtr(FHandle, GWLP_WNDPROC, MsgProcPointer);
end;
 
procedure TWndProcIntercept.UnregisterCB;
begin
if not FIsRegistered then exit;
FIsRegistered := false;
 
SetWindowLongPtr(FHandle, GWLP_WNDPROC, FPrevWndProc);
 
FreeProcInstance(MsgProcPointer);
end;
 
{ TQueryMenu }
 
function TQueryMenu.MsgProc(Handle: HWnd; Msg: UInt; WParam: Windows.WParam;
LParam: Windows.LParam): LResult;
begin
if Msg = WM_INITMENUPOPUP then
begin
FMenuOpened := true;
if Assigned(FOnMenuOpen) then
begin
FOnMenuOpen(Self);
end;
end;
if Msg = WM_UNINITMENUPOPUP then
begin
FMenuOpened := false;
if Assigned(FOnMenuClose) then
begin
FOnMenuClose(Self);
end;
end;
 
result := inherited MsgProc(Handle, Msg, WParam, LParam);
end;
 
{ TQuerySystemMenu }
 
function TQuerySystemMenu.MsgProc(Handle: HWnd; Msg: UInt; WParam: Windows.WParam; LParam: Windows.LParam): LResult;
begin
// TODO bug: löst bei evtl vorhandenen submenus öfters aus
if Msg = WM_INITMENUPOPUP then
begin
// if Cardinal(WParam) = GetSystemMenu(FHandle, False) then
if LongBool(HiWord(lParam)) then
begin
62,30 → 175,8
end;
end;
end;
Result := Windows.CallWindowProc(WNDPROC(FPrevWndProc), Handle, Msg, WParam, LParam);
end;
 
constructor TQuerySystemMenu.Create(AHandle: Hwnd);
var
f: TMethod;
begin
FHandle := AHandle;
 
FPrevWndProc := GetWindowLongPtr(FHandle, GWL_WNDPROC);
 
f.Code := @TQuerySystemMenu.MsgProc;
f.Data := Self;
MsgProcPointer := MakeProcInstance(f);
 
// Kann es zu Komplikationen mit mehreren msg handlern kommen?
SetWindowLongPtr(FHandle, GWL_WNDPROC, MsgProcPointer);
result := inherited MsgProc(Handle, Msg, WParam, LParam);
end;
 
destructor TQuerySystemMenu.Destroy;
begin
SetWindowLongPtr(FHandle, GWL_WNDPROC, FPrevWndProc);
 
FreeProcInstance(MsgProcPointer);
end;
 
end.
/trunk/Delphi Code/QuerySystemMenu/Demo.exe
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
/trunk/Delphi Code/QuerySystemMenu/Main.pas
10,13 → 10,14
TMainForm = class(TForm)
CheckBox1: TCheckBox;
Timer1: TTimer;
Label1: TLabel;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure SysMenuOpened(Sender: TObject);
procedure SysMenuClosed(Sender: TObject);
private
x: TQuerySystemMenu;
public
{ Public-Deklarationen }
end;
 
var
26,9 → 27,23
 
{$R *.dfm}
 
procedure TMainForm.SysMenuOpened(Sender: TObject);
begin
CheckBox1.Checked := true;
Label1.Caption := TimeToStr(Now());
end;
 
procedure TMainForm.SysMenuClosed(Sender: TObject);
begin
CheckBox1.Checked := false;
Label1.Caption := TimeToStr(Now());
end;
 
procedure TMainForm.FormCreate(Sender: TObject);
begin
x := TQuerySystemMenu.Create(Handle);
x.OnSystemMenuOpen := SysMenuOpened;
x.OnSystemMenuClose := SysMenuClosed;
end;
 
procedure TMainForm.FormDestroy(Sender: TObject);
38,7 → 53,7
 
procedure TMainForm.Timer1Timer(Sender: TObject);
begin
CheckBox1.Checked := x.IsSystemMenuOpened;
// CheckBox1.Checked := x.IsSystemMenuOpened;
end;
 
end.
/trunk/Delphi Code/QuerySystemMenu/MethodPtr.pas
1,6 → 1,6
unit MethodPtr;
 
// http://www.swissdelphicenter.ch/de/showcode.php?id=1671
// Ref: http://www.swissdelphicenter.ch/de/showcode.php?id=1671
 
interface
 
/trunk/Delphi Code/QuerySystemMenu/Main.dfm
15,6 → 15,13
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 144
Top = 184
Width = 31
Height = 13
Caption = 'Label1'
end
object CheckBox1: TCheckBox
Left = 112
Top = 128