When I try to use the Windows SetTimer function, it generate a IDEvent for the timer even if I have specified one!
This:
SetTimer(0,999,10000,#timerproc);
In:
procedure timerproc(hwnd: HWND; uMsg: UINT; idEvent: UINT_PTR;dwTime: DWORD); stdcall;
begin
KillTimer(0, idEvent);
showmessage(inttostr(idevent));
end;
Return:
Random Number!
Is it possible to manage my timers by myself instead of Windows choosing for me?
Thank you very much!
If you want to handle multiple timer events in a single routine, then handle it by specific window rather then by specific routine:
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
FTimerWindow: HWND;
procedure TimerProc(var Msg: TMessage);
end;
...
procedure TForm1.FormCreate(Sender: TObject);
begin
FTimerWindow := Classes.AllocateHWnd(TimerProc);
SetTimer(FTimerWindow, 999, 10000, nil);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Classes.DeallocateHWnd(FTimerWindow);
end;
procedure TForm1.TimerProc(var Msg: TMessage);
begin
if Msg.Msg = WM_TIMER then
with TWMTimer(Msg) do
case TimerID of
999:
//
else:
//
end;
end;
SetTimer will work differently, depending upon whether you are passing a window handle to it or not.
Timer_Indentifier := SetTimer(0, MyIdentifier, Time, #myproc);
In the above instance, Timer_Identifier does NOT equal MyIdentifier.
Timer_Indentifier := SetTimer(handle, MyIdentifier, Time, #myproc);
In the second example, Timer_Identifier = MyIdentifier.
This is because in the second example, your windows loop will need to use "MyIdentifier" to find out which timer is sending a "WM_Timer" message to it.
Using a specific Timer function, with no Window Handle, is different. The short answer is that in your scenario, use the value that Windows gives you.
http://msdn.microsoft.com/en-us/library/windows/desktop/ms644906%28v=vs.85%29.aspx
Multimedia Timer solved my problem!
I can pass whatever I want to them with dwUser:)
MMRESULT timeSetEvent(
UINT uDelay,
UINT uResolution,
LPTIMECALLBACK lpTimeProc,
DWORD_PTR dwUser,
UINT fuEvent
);
From MSDN : dwUser -> User-supplied callback data.
They have a TIME_ONESHOT option which is exactly what I use timers for!
Related
I've build a datasnap server application for handling data between a windows application and mobile apps.
One method can take a while, and I want to be able to stop it after a certain time(Timeout).
How can I achieve this?
The code below shows one way to provide a server method with timeout behaviour.
The task which may take too long is executed in a secondary thread which is
started in the server method. This method uses a TSimpleEvent object (see the online help) to enable the
secondary thread to signal back to the server method's thread that it has completed. The value (in milliseconds) you specify in the call to Event.WaitFor defines how long to wait before the call times out.
If the call to WaitFor on the SimpleEvent times out, you can take whatever action you
like to notify the server's client. If the call to WaitFor returns wsSignaled, that means that the DBThread must have called SetEvent on the Event object before the period specified when calling WaitFor expired.
Btw, this example was written for D7, so might require minor adaptation for
Seattle. Also it uses a TForm descendant as the "server", but should work equally well in a DataSnap server method, since the principle is the same.
It doesn't address the issue of how exactly to stop whatever task you kick off in the secondary thread, because whether that is possible and how to do it if it is depends on exactly what the task is. Because of that, and the fact that you probably wouldn't want to delay the server method by waiting for the DBThread to complete, it does not attempt to free the DBThread, though in the real world that should of course be done.
type
TServer = class;
TDBThread = class(TThread)
private
FServer: TServer;
FEvent: TSimpleEvent;
FCancelled : Boolean;
function GetCancelled: Boolean;
procedure SetCancelled(const Value: Boolean);
public
procedure Execute; override;
constructor Create(AServer : TServer);
property Server : TServer read FServer;
property Event : TSimpleEvent read FEvent;
property Cancelled : Boolean read GetCancelled write SetCancelled;
end;
TServer = class(TForm)
// ignore the fact that in this case, TServer is a descendant of TForm
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
protected
CS : TCriticalSection;
Event : TSimpleEvent;
public
procedure DoServerMethod;
end;
[...]
{ TDBThread }
constructor TDBThread.Create(AServer: TServer);
begin
inherited Create(True); // create suspended
FreeOnTerminate := False;
FServer := AServer;
FEvent := FServer.Event;
end;
procedure TDBThread.Execute;
var
StartTime : Cardinal;
begin
Cancelled := False;
// Following is for illustration ONLY, to simulate a process which takes time.
// Do not call Sleep() in a loop in a real thread
StartTime := GetTickCount;
repeat
Sleep(100);
until GetTickCount - StartTime > 5000;
if not Cancelled then begin
{ TODO : Transfer result back to server thread }
Event.SetEvent;
end;
end;
function TDBThread.GetCancelled: Boolean;
begin
FServer.CS.Enter;
try
Result := FCancelled;
finally
FServer.CS.Leave;
end;
end;
procedure TDBThread.SetCancelled(const Value: Boolean);
begin
FServer.CS.Enter;
try
FCancelled := Value;
finally
FServer.CS.Leave;
end;
end;
procedure TServer.DoServerMethod;
var
DBThread : TDBThread;
WaitResult : TWaitResult;
begin
DBThread := TDBThread.Create(Self);
DBThread.Resume;
WaitResult := Event.WaitFor(1000);
case WaitResult of
wrSignaled : begin
// the DBThread completed
ShowMessage('DBThread completed');
end;
wrTimeOut : begin
// the DBThread time out
DBThread.Cancelled := True;
ShowMessage('DBThread timed out');
// Maybe use PostThreadMessage here to tell the DBThread to abort (if possible)
// whatever task it is doing that has taken too long.
end;
end; {case}
{ TODO : Terminate and dispose of the DBThread }
end;
procedure TServer.FormCreate(Sender: TObject);
begin
CS := TCriticalSection.Create;
Event := TSimpleEvent.Create;
end;
procedure TServer.Button1Click(Sender: TObject);
begin
DoServerMethod;
end;
I try to exchange data between two applications in windows. I use an example from Zarko Gajic. It uses windows messaging and the example works great. There are a sender and a receiving application and some shared data: all coded for VCL. The code is shown below.
unit SenderMain;
{ How to send information (String, Image, Record) between two Delphi applications
http://delphi.about.com/od/windowsshellapi/a/wm_copydata.htm
Learn how to send the WM_CopyData message between two Delphi
applications to exchange information and make two applications
communicate. The accompanying source code demonstrates how to
send a string, record (complex data type) and even graphics
to another application.
~Zarko Gajic
About Delphi Programming
http://delphi.about.com
}
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, TlHelp32,
shared_data;
type
TSenderMainForm = class(TForm)
Button_Send_Data: TButton;
Log: TListBox;
procedure Button_Send_DataClick (Sender: TObject);
protected
procedure Loaded; override;
procedure SendString (send_string: aString);
end; // Class: TSenderMainForm //
var
SenderMainForm: TSenderMainForm;
implementation
{$R *.dfm}
{**************** NextWindow ****************}
function NextWindow (wnd: Thandle; list: Tstringlist):boolean; stdcall;
{This is the callback function which is called by EnumWindows procedure
for each top-level window. Return "true" to keep retrieving, return
"false" to stop EnumWindows from calling}
var
title: array [0..255] of char;
receiverHandle: HWND;//THandle;
win_name: PChar;
s: AnsiString;
begin
getwindowtext (wnd, title, 256);
s := AnsiString (pchar(#title));
if (s <> '') and (list.indexof (string (s)) < 0) then
begin
win_name := PaString (s);
receiverHandle := FindWindow (win_name, nil); // Find receiving app
s := AnsiString (Format ('%s (%d)', [s, receiverHandle]));
list.add (string (s));
end; // if
result:=true;
end;
procedure TSenderMainForm.Loaded;
begin
inherited Loaded;
enumwindows (#nextwindow, lparam (Log.Items)); {pass the list as a parameter}
end;
procedure TSenderMainForm.SendString (send_string: aString);
var copyDataStruct: TCopyDataStruct; { Declared in Windows.pas: TCopyDataStruct}
receiverHandle: THandle;
res: integer;
begin
// Copy string to CopyDataStruct
copyDataStruct.dwData := 1; //use it to identify the message contents
copyDataStruct.cbData := (1 + Length (send_string)) * SizeOf (Char);
copyDataStruct.lpData := PaString (send_string);
receiverHandle := FindWindow (PaString (cClassName), nil); // Find receiving app
if receiverHandle = 0 then // not found
begin
Log.Items.Add ('CopyData Receiver NOT found!');
end else // found, send message
begin
res := SendMessage (receiverHandle, WM_COPYDATA, Integer(Handle), Integer(#copyDataStruct));
Log.Items.Add (Format ('String sent, len = %d, result = %d', [copyDataStruct.cbData, res]));
Log.Items.Add ('"' + PaString (copyDataStruct.lpData) + '"');
end; // if
end; // SendString
procedure TSenderMainForm.Button_Send_DataClick (Sender: TObject);
begin
SendString (ParamStr (0));
end;
====================== Unit copyDataReceiver ================
unit ReceiverMain;
{ How to send information (String, Image, Record) between two Delphi applications
http://delphi.about.com/od/windowsshellapi/a/wm_copydata.htm }
interface
uses
Windows, Messages,
SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, shared_data;
type
TReceiverMainForm = class (TForm)
Log: TListBox;
procedure FormCreate(Sender: TObject);
private
procedure WMCopyData (var Msg: TWMCopyData); message WM_COPYDATA;
procedure WMSignalClose (var Msg: TMessage); message WM_SIGNAL_CLOSE;
procedure HandleCopyDataString (copyDataStruct: PCopyDataStruct);
end;
var ReceiverMainForm: TReceiverMainForm;
implementation
{$R *.dfm}
procedure TReceiverMainForm.FormCreate (Sender: TObject);
begin
Log.Clear;
end;
procedure TReceiverMainForm.WMSignalClose (var Msg: TMessage);
var pfn: PaString;
fn: aString;
begin
Log.Items.Add (Format ('Signal received, WParam = %d, LParam = %d', [Msg.WParam, Msg.LParam]));
pfn := PaString (Msg.LParam);
fn := aString (pfn);
Log.Items.Add (fn);
end;
procedure TReceiverMainForm.WMCopyData (var Msg: TWMCopyData);
var copyDataType: Int32;
begin
copyDataType := Msg.CopyDataStruct.dwData;
//Handle of the Sender
Log.Items.Add (Format ('WM_CopyData (type: %d) from: %d', [copyDataType, msg.From]));
HandleCopyDataString (Msg.CopyDataStruct);
//Send something back
msg.Result := Log.Items.Count;
end;
procedure TReceiverMainForm.HandleCopyDataString (copyDataStruct: PCopyDataStruct);
var mess: aString;
begin
mess := aString (PaString (copyDataStruct.lpData));
Log.Items.Add (Format ('Received string of length %d at %s', [Length (mess), DateToStr (Now)]));
Log.Items.Add ('"' + mess + '"');
end;
end.
================ unit shared_data ==========================
unit shared_data;
interface
uses Messages;
const
WM_SIGNAL_CLOSE = WM_APP + 2012;
ARG_AMI_1 = 285;
ARG_AMI_2 = 1;
cClassName = 'TReceiverMainForm';
type
aString = string;
PaString = PChar;
implementation
end.
The crux of the sender application is that it sends a WM_COPYDATA to the receiver. In order to find the receiver, FindWindow is used with the name of the receiving application (hard-coded) which returns a handle to the window. If the handle is zero, an error is shown.
When I duplicate this in an FMX application there are troubles. The FMX receiving part does not work, while the VCL receiver can receive messages from either the VCL sender or the FMX sender. The code of the FMX receiver is shown below.
Because I wasn't sure about the name of the windows I enumerated all windows, added the numeric handle to each window name and showed it in a listbox in the sender. All handles are zero. I have two questions:
Why are all handles zero in the enumeration?
Why can't I send a message to the FMX receiving applation?
Any help would be greatly appreciated.
unit copyDataReceiver;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Layouts, FMX.ListBox,
Windows, Messages, shared_data;
type
TReceiverMainForm = class (TForm)
Log: TListBox;
procedure FormCreate(Sender: TFMXObject);
private
procedure WMCopyData (var Msg: TWMCopyData); message WM_COPYDATA;
procedure WMSignalClose (var Msg: TMessage); message WM_SIGNAL_CLOSE;
procedure HandleCopyDataString (copyDataStruct: PCopyDataStruct);
end;
var ReceiverMainForm: TReceiverMainForm;
implementation
{$R *.fmx}
procedure TReceiverMainForm.FormCreate (Sender: TFMXObject);
begin
Log.Clear;
end;
procedure TReceiverMainForm.WMSignalClose (var Msg: TMessage);
var pfn: PaString;
fn: aString;
begin
Log.Items.Add (Format ('Signal received, WParam = %d, LParam = %d', [Msg.WParam, Msg.LParam]));
pfn := PaString (Msg.LParam);
fn := aString (pfn);
Log.Items.Add (fn);
end;
procedure TReceiverMainForm.WMCopyData (var Msg: TWMCopyData);
var copyDataType: Int32;
begin
copyDataType := Msg.CopyDataStruct.dwData;
//Handle of the Sender
Log.Items.Add (Format ('WM_CopyData (type: %d) from: %d', [copyDataType, msg.From]));
HandleCopyDataString (Msg.CopyDataStruct);
//Send something back
msg.Result := Log.Items.Count;
end;
procedure TReceiverMainForm.HandleCopyDataString (copyDataStruct: PCopyDataStruct);
var mess: aString;
begin
mess := aString (PaString (copyDataStruct.lpData));
Log.Items.Add (Format ('Received string of length %d at %s', [Length (mess), DateToStr (Now)]));
Log.Items.Add ('"' + mess + '"');
end;
end.
Why can't I send a message to the FMX receiving applation?
For VCL-Forms the ClassName is derived from the name of the form by simply
adding a leading 'T' to then Name.
e.g. If you have a Form named MyForm the ClassName is TMyForm.
Self.ClassName returns this name and a call to
Winapi.Windows.FindWindow(PChar(Self.ClassName), nil) returns the correct
Handle.
With FMX-Forms you will receive a ClassName builded in similar way.
For FMX-Forms the ClassName is derived from the name of the form by
adding leading 'FMT' to the name of the Form.
The ClassName returned by Self.ClassName, however, is the same as for VCL-Forms.
e.g. If you have a Form named MyFMXForm the ClassName is FMTMyFMXForm but
Self.ClassName returns TMyFMXForm.
Therefore an attempt to get the window-handle with that ClassName fails.
The correct call is
Winapi.Windows.FindWindow(PChar('FMTMyFMXForm'), nil)); .
FindWindow works just the same under FMX. The problem is that sending messages to the window that you find will not result in them being routed to the form's message handlers.
Instead you should do what you should always have done, even with the VCL. That is use a known window whose lifetime you control. Remember that VCL windows are subject to recreation. In other words, you might have a window handle for a window in another process, but that window may be destroyed before you get a chance to send your message to it.
Resolve this by using AllocateHWnd or CreateWindow to create a window that will not be recreated. A window whose lifetime you control. You'll have to devise a way for the other process to discover your window. Personally I would use CreateWindow with a known class name, and then enumerate top level windows with EnumWindows looking for windows that that class name.
I want my form to handle the arrow keys, and I can do it -- as long as there is no button on the form. Why is this?
Key messages are processed by the controls themselves who receives these messages, that's why when you're on a button the form is not receiving the message. So normally you would have to subclass these controls, but the VCL is kind enough to ask the parenting form what to do if the form is interested:
type
TForm1 = class(TForm)
..
private
procedure DialogKey(var Msg: TWMKey); message CM_DIALOGKEY;
..
procedure TForm1.DialogKey(var Msg: TWMKey);
begin
if not (Msg.CharCode in [VK_DOWN, VK_UP, VK_RIGHT, VK_LEFT]) then
inherited;
end;
François editing: to answer the OP original question, you need to call onKeyDown somehow so that his event code would work (feel free to edit; was too long for a comment).
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
private
{ Private declarations }
procedure DialogKey(var Msg: TWMKey); message CM_DIALOGKEY;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.DialogKey(var Msg: TWMKey);
begin
case Msg.CharCode of
VK_DOWN, VK_UP, VK_RIGHT, VK_LEFT:
if Assigned(onKeyDown) then
onKeyDown(Self, Msg.CharCode, KeyDataToShiftState(Msg.KeyData));
else
inherited
end;
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
case Key of
VK_DOWN: Top := Top + 5;
VK_UP: Top := Top - 5;
VK_LEFT: Left := Left - 5;
VK_RIGHT: Left := Left + 5;
end;
end;
Arrow keys are used to navigate between buttons on a form. This is standard Windows behaviour. Although you can disable this standard behaviour you should think twice before going against the platform standard. Arrow keys are meant for navigation.
If you want to get the full low down on how a key press finds its way through the message loop I recommend reading A Key's Odyssey. If you want to intercept the key press before it becomes a navigation key, you need to do so in IsKeyMsg or earlier. For example, Sertac's answer gives one such possibility.
Only the object that has the focus can receive a keyboard event.
To let the form have access to the arrow keys event,
declare a MsgHandler in the public part of the form.
In the form create constructor, assign the Application.OnMessage to this MsgHandler.
The code below intercepts the arrow keys only if they are coming from a TButton descendant. More controls can be added as needed.
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnMessage := Self.MsgHandler;
end;
procedure TForm1.MsgHandler(var Msg: TMsg; var Handled: Boolean);
var
ActiveControl: TWinControl;
key : word;
begin
if (Msg.message = WM_KEYDOWN) then
begin
ActiveControl := Screen.ActiveControl;
// if the active control inherits from TButton, intercept the key.
// add other controls as fit your needs
if not ActiveControl.InheritsFrom(TButton)
then Exit;
key := Msg.wParam;
Handled := true;
case Key of // intercept the wanted keys
VK_DOWN : ; // doStuff
VK_UP : ; // doStuff
VK_LEFT : ; // doStuff
VK_RIGHT : ; // doStuff
else Handled := false;
end;
end;
end;
Because they are preempted to deal with setting the focus on the next available WinControl.
(I'm pretty sure that if you put an Edit instead of a Button you see the same thing).
If you want to handle them yourself, you can provide the Application with an OnMessage event that will filter those before they are processed and handle them yourself there.
var
KBHook: HHook; {this intercepts keyboard input}
implementation
{$R *.dfm}
function KeyboardHookProc(Code: Integer; WordParam: Word; LongParam: LongInt): LongInt; stdcall;
begin
case WordParam of
vk_Space: ShowMessage ('space') ;
vk_Right:ShowMessage ('rgt') ;
vk_Left:ShowMessage ('lft') ;
vk_Up: ShowMessage ('up') ;
vk_Down: ShowMessage ('down') ;
end; {case}
end;
procedure TForm4.FormCreate(Sender: TObject);
begin
KBHook:=SetWindowsHookEx(WH_KEYBOARD,#KeyboardHookProc,HInstance,GetCurrentThreadId());
end;
This code will work even when a control is focused (buttons , listboxes), so be careful some controls may loose their keyboard events (Read David haffernans answer) .
keyboard events with Focused controls
eg: If you are having textbox in your app and want to recive text(if focused) also , then
add an applicationevent1
procedure TForm4.ApplicationEvents1Message(var Msg: tagMSG;var Handled: Boolean);
begin
if Msg.message = WM_KEYFIRST then
KBHook:=SetWindowsHookEx(WH_KEYBOARD,#KeyboardHookProc,HInstance,GetCurrentThreadId());
end;
add the following code at the bottom of the function KeyboardHookProc
UnhookWindowsHookEx(KBHook);
and remove
KBHook:=SetWindowsHookEx(WH_KEYBOARD,#KeyboardHookProc, HInstance,
GetCurrentThreadId());
from oncreate event.
I Delphi, I need a function which determinates if the system menu (resp. window menu, the menu that appears when the icon is clicked) is opened. The reason is that I am writing a anti-keylogger functionality which sends garbage to the current active editcontrol (this also prevents keylogger which read WinAPI messages to read the content). But if system-menu is opened, the editcontrol STILL has the focus, so the garbage will invoke shortcuts.
If I use message WM_INITMENUPOPUP in my TForm1, I can determinate when the system menu opens, but I wish that I do not have to change the TForm, since I want to write a non visual component, which does not need any modifications at the TForm-derivate-class itself.
//I do not want that solution since I have to modify TForm1 for that!
procedure TForm1.WMInitMenuPopup(var Message: TWMInitMenuPopup);
begin
if message.MenuPopup=getsystemmenu(Handle, False) then
begin
SystemMenuIsOpened := true;
end;
end;
TApplicaton.HookMainWindow() does not send the WM_INITMENUPOPUP to my hook function.
function TForm1.MessageHook(var Msg: TMessage): Boolean;
begin
Result := False;
if (Msg.Msg = WM_INITMENUPOPUP) then
begin
// Msg.Msg IS NEVER WM_INITMENUPOPUP!
if LongBool(msg.LParamHi) then
begin
SystemMenuIsOpened := true;
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.HookMainWindow(MessageHook);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Application.UnhookMainWindow(MessageHook);
end;
Even after very long research I did not found any information about how to query if the system-menu is opened or not. I do not find any way to determinate the opening+closing of that menu.
Has someone a solution for me please?
Regards
Daniel Marschall
Application.HookMainWindow doesn't do what you seem to think. It hooks the hidden application window, not the main form. To intercept WM_INITMENUPOPUP on a specific form, all you need to do is write a handler for it, as you have seen.
To do this generically for any owner form of a component, you could assign WindowProc property of the form to place the hook:
unit FormHook;
interface
uses
Windows, Classes, SysUtils, Messages, Controls, Forms;
type
TFormMessageEvent = procedure(var Message: TMessage; var Handled: Boolean) of object;
TFormHook = class(TComponent)
private
FForm: TCustomForm;
FFormWindowProc: TWndMethod;
FOnFormMessage: TFormMessageEvent;
protected
procedure FormWindowProc(var Message: TMessage); virtual;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property OnFormMessage: TFormMessageEvent read FOnFormMessage write FOnFormMessage;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Test', [TFormHook]);
end;
procedure TFormHook.FormWindowProc(var Message: TMessage);
var
Handled: Boolean;
begin
if Assigned(FFormWindowProc) then
begin
Handled := False;
if Assigned(FOnFormMessage) then
FOnFormMessage(Message, Handled);
if not Handled then
FFormWindowProc(Message);
end;
end;
constructor TFormHook.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FFormWindowProc := nil;
FForm := nil;
while Assigned(AOwner) do
begin
if AOwner is TCustomForm then
begin
FForm := TCustomForm(AOwner);
FFormWindowProc := FForm.WindowProc;
FForm.WindowProc := FormWindowProc;
Break;
end;
AOwner := AOwner.Owner;
end;
end;
destructor TFormHook.Destroy;
begin
if Assigned(FForm) and Assigned(FFormWindowProc) then
begin
FForm.WindowProc := FFormWindowProc;
FFormWindowProc := nil;
FForm := nil;
end;
inherited Destroy;
end;
end.
You could then use this component on a form:
procedure TForm1.FormHook1FormMessage(var Message: TMessage; var Handled: Boolean);
begin
case Message.Msg of
WM_INITMENUPOPUP:
...
end;
end;
The problem might be that if the form has any other components which do the same thing then you need to make sure that unhooking happens in reverse order (last hooked, first unhooked). The above example hooks in the constructor and unhooks in the destructor; this seems to work even with multiple instances on the same form.
If you don't want any modifications to TForm-derivate-class, why don't try pure Windows API way to implement your current solution, that is, use SetWindowLongPtr() to intercept the WM_INITMENUPOPUP message. Delphi VCL style to intercept messages is just a wrapper of this Windows API function actually.
For that purpose, use SetWindowLongPtr() to set a new address for the window procedure and to get the original address of the window procedure, both at one blow. Remember to store the original address in a LONG_PTR variable. In 32-bit Delphi, LONG_PTR was Longint; supposing 64-bit Delphi will have been released in the future, LONG_PTR should be Int64; you can use $IFDEF directive to distinguish them as follows:
Type
{$IFDEF WIN32}
PtrInt = Longint;
{$ELSE}
PtrInt = Int64;
{$ENDIF}
LONG_PTR = PtrInt;
The value for nIndex parameter to be used for this purpose is GWLP_WNDPROC. Also, pass the new address for the window procedure to dwNewLong parameter, e.g. LONG_PTR(NewWndProc). The NewWndProc is a WindowProc Callback Function that processes messages, it is where your put your intercept criteria and override the default handling of the message you are going to intercept. The callback function can be any name, but the parameters must follow the WindowProc convention.
Note that you must call CallWindowProc() to pass any messages not processed by the new window procedure to the original window procedure.
Finally, you should call SetWindowLongPtr() again somewhere in your code to set the address of modified/new window procedure handler back to the original address. The original address has been saved before as mentioned above.
There was a Delphi code example here. It used SetWindowLong(), but now Microsoft recommends to use SetWindowLongPtr() instead to make it compatible with both 32-bit and 64-bit versions of Windows.
SetWindowLongPtr() didn't exist in Windows.pas of Delphi prior to Delphi 2009. If you use an older version of Delphi, you must declare it by yourself, or use JwaWinUser unit of JEDI API Library.
Not tried this myself, but give this a shot:
Use GetMenuItemRect to get the rect for item 0 of the menu returned by GetSystemMenu.
I (assume!) GetMenuItemRect should return 0 if the system menu is not open (because system could not know the rect of the menu item unless it is open?) If the result is non-zero, check if the coords returned are possible for the given screen resolution.
If you have the time, you could look into AutoHotKey's source code to see how to monitor when system menu is open/closed.
I want to minimize a Delphi application to the systray instead of the task bar.
The necessary steps seem to be the following:
Create icon which should then be displayed in the systray.
When the user clicks the [-] to minimize the application, do the following:
Hide the form.
Add the icon (step #1) to the systray.
Hide/delete the application's entry in the task bar.
When the user double-clicks the application's icon in the systray, do the following:
Show the form.
Un-minimize the application again and bring it to the front.
If "WindowState" is "WS_Minimized" set to "WS_Normal".
Hide/delete the application's icon in the systray.
When the user terminates the application, do the following:
Hide/delete the application's icon in the systray.
That's it. Right?
How could one implement this in Delphi?
I've found the following code but I don't know why it works. It doesn't follow my steps described above ...
unit uMinimizeToTray;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ShellApi;
const WM_NOTIFYICON = WM_USER+333;
type
TMinimizeToTray = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure CMClickIcon(var msg: TMessage); message WM_NOTIFYICON;
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
MinimizeToTray: TMinimizeToTray;
implementation
{$R *.dfm}
procedure TMinimizeToTray.CMClickIcon(var msg: TMessage);
begin
if msg.lparam = WM_LBUTTONDBLCLK then Show;
end;
procedure TMinimizeToTray.FormCreate(Sender: TObject);
VAR tnid: TNotifyIconData;
HMainIcon: HICON;
begin
HMainIcon := LoadIcon(MainInstance, 'MAINICON');
Shell_NotifyIcon(NIM_DELETE, #tnid);
tnid.cbSize := sizeof(TNotifyIconData);
tnid.Wnd := handle;
tnid.uID := 123;
tnid.uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
tnid.uCallbackMessage := WM_NOTIFYICON;
tnid.hIcon := HMainIcon;
tnid.szTip := 'Tooltip';
Shell_NotifyIcon(NIM_ADD, #tnid);
end;
procedure TMinimizeToTray.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caNone;
Hide;
end;
end.
If it still works, it's probably easiest to use JVCL's TJvTrayIcon to handle it automatically.
I would recommend using CoolTrayIcon. The author has already worked out all the issues involved with tray icons. Its free with source and examples and very debugged.
http://subsimple.com/delphi.asp
Instead of Application.BringToFront; use SetforegroundWindow(Application.Handle);
In the following text I'll be referring to the step numbers mentioned in the question:
The following solution is without any additional components. It's very easy to implement.
Step #1:
Just use the application's main icon (see following code).
Step #2:
procedure TForm1.ApplicationEvents1Minimize(Sender: TObject);
begin
Shell_NotifyIcon(NIM_ADD, #TrayIconData);
Form1.Hide;
end;
Step #3:
procedure TForm1.TrayMessage(var Msg: TMessage);
begin
if Msg.lParam = WM_LBUTTONDOWN then begin
Form1.Show;
Form1.WindowState := wsNormal;
Application.BringToFront;
Shell_NotifyIcon(NIM_DELETE, #TrayIconData);
end;
end;
Step #4:
procedure TForm1.FormDestroy(Sender: TObject);
begin
Shell_NotifyIcon(NIM_DELETE, #TrayIconData);
end;
Necessary code in interface part:
uses
[...], ShellApi;
const
WM_ICONTRAY = WM_USER + 1;
type
TForm1 = class(TForm)
[...]
procedure TrayMessage(var Msg: TMessage); message WM_ICONTRAY;
end;
The only problem: The application can be minimized to the systray only once. The next time you want to minimize it, nothing will happen. Why?
Source: delphi.about.com