Delphi: How to use ShowWindow properly on external application [duplicate] - delphi

This question already has an answer here:
How can I make the second instance of my program pass control back to the first instance?
(1 answer)
Closed 8 years ago.
See also:
How can I tell if another instance of my program is already running?
i use the following code before starting my application, to check if another instance
of it is already started:
var _PreviousHandle : THandle;
begin
_PreviousHandle := FindWindow('TfrmMainForm',nil);
if _PreviousHandle <> 0 then
begin
ShowMessage('Application "" is already running!');
SetForegroundWindow(_PreviousHandle);
ShowWindow(_PreviousHandle, SW_SHOW);
Application.Terminate;
Exit;
end;
...
However, if it has started, i need to show that application. The problem is after it is shown in this way the minimize button no longer works, and when i click the icon in the taskbar, it "unminimizes" and the animation that is shown is as if it was minimized. Am i missing something? is there a proper way to activate and show external application while it's minimized?

Here is a complete project, which keeps running only one instance of the application, and which should bring already running instance window to front.
You can download a testing project or try the code, which follows:
Project1.dpr
program Project1;
uses
Forms,
Windows,
Unit1 in 'Unit1.pas' {Form1};
{$R *.res}
var
Mutex: THandle;
const
AppID = '{0AEEDBAF-2643-4576-83B1-8C9422726E98}';
begin
MessageID := RegisterWindowMessage(AppID);
Mutex := CreateMutex(nil, False, AppID);
if (Mutex <> 0) and (GetLastError = ERROR_ALREADY_EXISTS) then
begin
PostMessage(HWND_BROADCAST, MessageID, 0, 0);
Exit;
end;
Application.Initialize;
Application.MainFormOnTaskbar := True;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
Unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StrUtils, StdCtrls;
type
TForm1 = class(TForm)
private
function ForceForegroundWindow(WndHandle: HWND): Boolean;
function ForceRestoreWindow(WndHandle: HWND; Immediate: Boolean): Boolean;
protected
procedure WndProc(var AMessage: TMessage); override;
end;
var
Form1: TForm1;
MessageID: UINT;
implementation
{$R *.dfm}
{ TForm1 }
function TForm1.ForceForegroundWindow(WndHandle: HWND): Boolean;
var
CurrThreadID: DWORD;
ForeThreadID: DWORD;
begin
Result := True;
if (GetForegroundWindow <> WndHandle) then
begin
CurrThreadID := GetWindowThreadProcessId(WndHandle, nil);
ForeThreadID := GetWindowThreadProcessId(GetForegroundWindow, nil);
if (ForeThreadID <> CurrThreadID) then
begin
AttachThreadInput(ForeThreadID, CurrThreadID, True);
Result := SetForegroundWindow(WndHandle);
AttachThreadInput(ForeThreadID, CurrThreadID, False);
if Result then
Result := SetForegroundWindow(WndHandle);
end
else
Result := SetForegroundWindow(WndHandle);
end;
end;
function TForm1.ForceRestoreWindow(WndHandle: HWND;
Immediate: Boolean): Boolean;
var
WindowPlacement: TWindowPlacement;
begin
Result := False;
if Immediate then
begin
WindowPlacement.length := SizeOf(WindowPlacement);
if GetWindowPlacement(WndHandle, #WindowPlacement) then
begin
if (WindowPlacement.flags and WPF_RESTORETOMAXIMIZED) <> 0 then
WindowPlacement.showCmd := SW_MAXIMIZE
else
WindowPlacement.showCmd := SW_RESTORE;
Result := SetWindowPlacement(WndHandle, #WindowPlacement);
end;
end
else
Result := SendMessage(WndHandle, WM_SYSCOMMAND, SC_RESTORE, 0) = 0;
end;
procedure TForm1.WndProc(var AMessage: TMessage);
begin
inherited;
if AMessage.Msg = MessageID then
begin
if IsIconic(Handle) then
ForceRestoreWindow(Handle, True);
ForceForegroundWindow(Application.Handle);
end;
end;
end.
Tested on OS versions:
Windows 8.1 64-bit
Windows 7 SP1 64-bit Home Premium
Windows XP SP 3 32-bit Professional
Known issues and limitations:
The MainFormOnTaskbar is not taken into account at all; it must be set to True at this time

You're asking your Main form to show, but it may occur the application hidden window itself is minimized when you minimize the application to the task bar, in case of MainFormOnTaskBar being false.
Don't call the ShowWindow method from the oustide. IMHO it's better if you pass a message to the application and respond from inside, calling the Application.Restore` method, which performs the proper ShowWindow calls among other things.

This is a very common problem with VCL apps, and has been asked and answered many many times in the Borland/CodeGear/Embarcadero forums over the years. Using ShowWindow() in this manner does not work for VCL windows very well because of the way the MainForm interacts with the TApplication object at runtime, especially in different versions of Delphi. What you should do instead is have the second instance send a custom message to the first instance, and then let the first instance restore itself as needed when it receives the message, such as by setting its MainForm.WindowState property, or calling Application.Restore(), etc, and let the VCL work out the details for you, like #jachguate suggested.

The following works well for me. I'm not 100% certain I have fully understood the question though, so do let me know if I've got it wrong.
var
_PreviousHandle: HWND;
WindowPlacement: TWindowPlacement;
....
WindowPlacement.length := SizeOf(WindowPlacement);
GetWindowPlacement(_PreviousHandle, WindowPlacement);
if WindowPlacement.flags and WPF_RESTORETOMAXIMIZED<>0 then
WindowPlacement.showCmd := SW_MAXIMIZE
else
WindowPlacement.showCmd := SW_RESTORE;
SetWindowPlacement(_PreviousHandle, WindowPlacement);
SetForegroundWindow(_PreviousHandle);
Note that the correct type for _PreviousHandle is HWND and not THandle.

Related

Delphi FreeLibrary freezes when using TTask in DLL

Here is my code in DLL:
procedure TTaskTest;
begin
TTask.Run(
procedure
begin
Sleep(300);
end);
end;
exports TTaskTest;
After calling this method in host app, then call FreeLibrary will freeze host app.
After debug , I found that the program freezes at if TMonitor.Wait(FLock, Timeout) then in TLightweightEvent.WaitFor , but the debugger cannot step into TMonitor.Wait.
How to solve?
This issue was reported (RSP-13742 Problem with ITask, IFuture inside DLL).
It was closed "Works as Expected" with a remark:
To prevent this failure using ITask or IFuture from a DLL, the DLL will need to be using its own instance of TThreadPool in place of the default instance of TThreadPool.
Here is an example from Embarcadero how to handle it:
library TestLib;
uses
System.SysUtils,
System.Classes,
System.Threading;
{$R *.res}
VAR
tpool: TThreadPool;
procedure TestDelay;
begin
tpool := TThreadPool.Create;
try
TTask.Run(
procedure begin
Sleep(300);
end,
tpool
);
finally
FreeAndNil(tpool);
end;
end;
exports
TestDelay;
begin
end.
Another way is to create the threadpool when the library is loaded, and add a release procedure, which you call before calling FreeLibrary.
// In dll
procedure TestDelay;
begin
TTask.Run(
procedure begin
Sleep(300);
end,
tpool
);
end;
procedure ReleaseThreadPool;
begin
FreeAndNil(tpool);
end;
exports
TestDelay,ReleaseThreadPool;
begin
tpool := TThreadPool.Create;
end.

How to open .pas file from another app in already open Delphi IDE and position to line#

Assuming I have the Delphi IDE open, how can I open a .pas file selected in another app and open it in the Delphi IDE, as well as positioning it to a specific line number?
I've seen some editing tools do this.
I'm not sure if it's just an option to a normal file open (eg., using default file association), or a command-line option, or you need DDE or COM or something entirely different.
Note that I don't want to close the project and reopen a new or fake project.
Also, I don't want the file added to the project. I just want to open it.
For example, When you <ctrl>-click on a varible or type, the IDE will open the file containing that symbol and go to the line where that symbol is declared. That's all I want to do -- but from an external app. (I'm not looking for a symbol, just a line.)
I'm using Delphi XE5 at the moment, so I'm interested in newer Delphi versions, not pre-XE2 or so.
(Part of the question is, how do I ensure that if the IDE is already open, the the file is opened in anew tab inside of the current IDE rather than in another instance of the IDE?)
The code below (for D7) shows how this can be done by way of an IDE add-in .Dpk compiled
into a Bpl. It started as just a "proof of concept", but it does actually work.
It comprises a "sender" application which uses WM_COPYDATA to send the FileName, LineNo & Column to a receiver hosted in the .Bpl file.
The sender sends the receiver a string like
Filename=d:\aaad7\ota\dskfilesu.pas
Line=8
Col=12
Comment=(* some comment or other*)
The Comment line is optional.
In the .Bpl, the receiver uses OTA services to open the requested file and positions the editor caret, then inserts the comment, if any.
The trickiest thing was to find out how to handle one particular complication, the case where the named file to be opened is one with an associated form. If so, in D7 (and, I assume, other IDE versions with the floating designer option enabled) when the IDE
opens the .Pas file, it also opens the .Dfm, and left to its own devices, that would leave the form editor in front of the code editor. Calling the IOTASourceEditor.Show for the .Pas file at least puts the IDE code editor in front of the .Dfm form, but that didn't satisfy me, because by now my curiosity was piqued - how do you get a form the IDE is displaying off the screen?
I spent a lot of time exploring various blind alleys, because the OTA + NTA services don't seem to provide any way to explicitly close an IOTAEditor or any of its descendants. In the end it turned out that the thing to do is simply get a reference to the form and just send it a WM_CLOSE(!) - see comments in the code.
Fwiw, being a novice at OTA, at first (before I found out how IOTAModules work) I found that far and away the most difficult part of this was discovering how to get hold of the IEditView interface needed to set the editor caret position, but as usual with these interfacey things, once you get the "magic spell" exactly right, it all works.
Good luck! And thanks for the fascinating challenge!
unit Receiveru;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, ToolsAPI;
type
TOTAEditPosnForm = class(TForm)
Memo1: TMemo;
private
FEdLine: Integer;
FEdCol: Integer;
FEditorFileName: String;
FEditorInsert: String;
procedure WMCopyData(var Msg : TWMCopyData); message WM_COPYDATA;
procedure HandleCopyDataString(CopyDataStruct : PCopyDataStruct);
procedure OpenInIDEEditor;
property EditorFileName : String read FEditorFileName write FEditorFileName;
property EdLine : Integer read FEdLine write FEdLine;
property EdCol : Integer read FEdCol write FEdCol;
property EditorInsert : String read FEditorInsert write FEditorInsert;
end;
var
OTAEditPosnForm: TOTAEditPosnForm;
procedure Register;
implementation
{$R *.dfm}
procedure MonitorFiles;
begin
OTAEditPosnForm := TOTAEditPosnForm.Create(Nil);
OTAEditPosnForm.Show;
end;
procedure Register;
begin
MonitorFiles;
end;
procedure TOTAEditPosnForm.OpenInIDEEditor;
var
IServices : IOTAServices;
IActionServices : IOTAActionServices;
IModuleServices : IOTAModuleServices;
IEditorServices : IOTAEditorServices60;
IModule : IOTAModule;
i : Integer;
IEditor : IOTAEditor;
ISourceEditor : IOTASourceEditor;
IFormEditor : IOTAFormEditor;
IComponent : IOTAComponent;
INTAComp : INTAComponent;
AForm : TForm;
IEditView : IOTAEditView;
CursorPos : TOTAEditPos;
IEditWriter : IOTAEditWriter;
CharPos : TOTACharPos;
InsertPos : Longint;
FileName : String;
begin
IServices := BorlandIDEServices as IOTAServices;
Assert(Assigned(IServices), 'IOTAServices not available');
IServices.QueryInterface(IOTAACtionServices, IActionServices);
if IActionServices <> Nil then begin
IServices.QueryInterface(IOTAModuleServices, IModuleServices);
Assert(IModuleServices <> Nil);
// Close all files open in the IDE
IModuleServices.CloseAll;
if IActionServices.OpenFile(EditorFileName) then begin
// At this point, if the named file has an associated .DFM and
// we stopped here, the form designer would be in front of the
// code editor.
IModule := IModuleServices.Modules[0];
// IModule is the one holding our .Pas file and its .Dfm, if any
// So, iterate the IModule's editors until we find the one
// for the .Pas file and then call .Show on it. This will
// bring the code editor in front of the form editor.
ISourceEditor := Nil;
for i := 0 to IModule.ModuleFileCount - 1 do begin
IEditor := IModule.ModuleFileEditors[i];
FileName := IEditor.FileName;
Memo1.Lines.Add(Format('%d %s', [i, FileName]));
if CompareText(ExtractFileExt(IEditor.FileName), '.Pas') = 0 then begin
if ISourceEditor = Nil then begin
IEditor.QueryInterface(IOTASourceEditor, ISourceEditor);
IEditor.Show;
end
end
else begin
// Maybe the editor is a Form Editor. If it is
// close the form (the counterpart to the .Pas, that is}
IEditor.QueryInterface(IOTAFormEditor, IFormEditor);
if IFormEditor <> Nil then begin
IComponent := IFormEditor.GetRootComponent;
IComponent.QueryInterface(INTAComponent, INTAComp);
AForm := TForm(INTAComp.GetComponent);
//AForm.Close; < this does NOT close the on-screen form
// IActionServices.CloseFile(IEditor.FileName); <- neither does this
SendMessage(AForm.Handle, WM_Close, 0, 0); // But this does !
end;
end;
end;
// Next, place the editor caret where we want it ...
IServices.QueryInterface(IOTAEditorServices, IEditorServices);
Assert(IEditorServices <> Nil);
IEditView := IEditorServices.TopView;
Assert(IEditView <> Nil);
CursorPos.Line := edLine;
CursorPos.Col := edCol;
IEditView.SetCursorPos(CursorPos);
// and scroll the IEditView to the caret
IEditView.MoveViewToCursor;
// Finally, insert the comment, if any
if EditorInsert <> '' then begin
Assert(ISourceEditor <> Nil);
IEditView.ConvertPos(True, CursorPos, CharPos);
InsertPos := IEditView.CharPosToPos(CharPos);
IEditWriter := ISourceEditor.CreateUndoableWriter;
Assert(IEditWriter <> Nil, 'IEditWriter');
IEditWriter.CopyTo(InsertPos);
IEditWriter.Insert(PChar(EditorInsert));
IEditWriter := Nil;
end;
end;
end;
end;
procedure TOTAEditPosnForm.HandleCopyDataString(
CopyDataStruct: PCopyDataStruct);
begin
Memo1.Lines.Text := PChar(CopyDataStruct.lpData);
EditorFileName := Memo1.Lines.Values['FileName'];
edLine := StrToInt(Memo1.Lines.Values['Line']);
edCol := StrToInt(Memo1.Lines.Values['Col']);
EditorInsert := Trim(Memo1.Lines.Values['Comment']);
if EditorFileName <> '' then
OpenInIDEEditor;
end;
procedure TOTAEditPosnForm.WMCopyData(var Msg: TWMCopyData);
begin
HandleCopyDataString(Msg.CopyDataStruct);
msg.Result := Length(Memo1.Lines.Text);
end;
initialization
finalization
if Assigned(OTAEditPosnForm) then begin
OTAEditPosnForm.Close;
FreeAndNil(OTAEditPosnForm);
end;
end.
Code for sender:
procedure TSenderMainForm.btnSendClick(Sender: TObject);
begin
SendMemo;
end;
procedure TSenderMainForm.SendData(
CopyDataStruct: TCopyDataStruct);
var
HReceiver : THandle;
Res : integer;
begin
HReceiver := FindWindow(PChar('TOTAEditPosnForm'),PChar('OTAEditPosnForm'));
if HReceiver = 0 then begin
Caption := 'CopyData Receiver NOT found!';
end
else begin
Res := SendMessage(HReceiver, WM_COPYDATA, Integer(Handle), Integer(#CopyDataStruct));
if Res > 0 then
Caption := Format('Received %d characters', [Res]);
end;
end;
procedure TSenderMainForm.SendMemo;
var
MS : TMemoryStream;
CopyDataStruct : TCopyDataStruct;
S : String;
begin
MS := TMemoryStream.Create;
try
S := Memo1.Lines.Text + #0;
MS.Write(S[1], Length(S));
CopyDataStruct.dwData := 1;
CopyDataStruct.cbData := MS.Size;
CopyDataStruct.lpData := MS.Memory;
SendData(CopyDataStruct);
finally
MS.Free;
end;
end;

Window receives infinite amount of messages when mouse is hooked

I am writing an application which should draw a circle in place where user clicks a mouse. To achieve that i am hooking the mouse globally using SetWindowHookEx(WH_MOUSE,...)
The hooking, and the procedure that processes mouse action is in DLL. The procedure posts a registered message when it finds that mouse button was clicked using PostMessage(FindWindow('TMyWindow',nil), MyMessage, 0,0);
My application with TMyWindow form processes the messages in WndProc procedure. I check whether the message that came is the same as my registered one and only then draw the circle. After drawing the circle i create a timer, which should free the image after 500ms.
So everything seems to work just fine until i actually click on any part of my application form (for example click on still existing circle that was drawn not long ago). When i do that, form starts receiving my registered messages infinitely ans of course circle drawing procedure gets called every time.
I dont understand why is it doing so. Why is it working fine when i click somewhere off my application form but hangs when i click inside my form?
Let me know if you need more details.
Thanks
EDIT 1:
Main unit. $202 message is WM_LBUTTONUP.
unit main;
interface
uses
HookCommon,
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, Menus, AppEvnts;
type
TTimer2 = class(TTimer)
private
FShape: TShape;
public
destructor Destroy; override;
property Shape: TShape read FShape write FShape;
end;
type
TShowMouseClick = class(TForm)
timerCountTimer: TTimer;
tray: TTrayIcon;
popMenu: TPopupMenu;
mnuExit: TMenuItem;
mnuActive: TMenuItem;
N1: TMenuItem;
mnuSettings: TMenuItem;
timersStx: TStaticText;
procedure timerCountTimerTimer(Sender: TObject);
procedure mnuExitClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
timerList: TList;
procedure shape();
procedure freeInactive(var Msg: TMessage); message WM_USER + 1545;
public
shapeColor: Tcolor;
procedure TimerExecute(Sender: TObject);
protected
procedure WndProc(var Message: TMessage); override;
{ Public declarations }
end;
var
ShowMouseClick: TShowMouseClick;
implementation
{$R *.dfm}
uses settings;
{$REGION 'Hide from TaskBar'}
procedure TShowMouseClick.FormActivate(Sender: TObject);
begin
ShowWindow(Application.Handle, SW_HIDE);
end;
procedure TShowMouseClick.FormShow(Sender: TObject);
begin
ShowWindow(Application.Handle, SW_HIDE);
end;
{$ENDREGION}
procedure TShowMouseClick.WndProc(var Message: TMessage);
begin
inherited WndProc(Message);
if (Message.Msg = HookCommon.MouseHookMessage) and
(Message.WParam = $202) then
shape;
end;
procedure TShowMouseClick.FormCreate(Sender: TObject);
begin
BorderStyle := bsNone;
FormStyle := fsStayOnTop;
WindowState := wsMaximized;
mnuActive.Checked := true;
HookCommon.HookMouse;
timerList := TList.Create;
timerList.Clear;
shapeColor := clGreen;
end;
procedure TShowMouseClick.FormDestroy(Sender: TObject);
begin
HookCommon.UnHookMouse;
end;
procedure TShowMouseClick.mnuExitClick(Sender: TObject);
begin
Close;
end;
procedure TShowMouseClick.timerCountTimerTimer(Sender: TObject);
begin
timersStx.Caption := 'Active timers: ' + IntToStr(timerList.Count);
end;
procedure TShowMouseClick.shape;
var
tm: TTimer2;
begin
tm := TTimer2.Create(nil);
tm.Tag := 0 ;
tm.Interval := 1;
tm.OnTimer := TimerExecute;
tm.Shape := nil;
timerList.Add(tm);
timersStx.Caption := 'Active timers: ' + IntToStr(timerList.Count);
tm.Enabled := true;
end;
procedure TShowMouseClick.TimerExecute(Sender: TObject);
var
img: TShape;
snd: TTimer2;
begin
snd := nil;
if Sender is TTimer2 then
snd := TTimer2(Sender);
if snd = nil then Exit;
if snd.Tag = 0 then
begin
snd.Interval := 500;
img := TShape.Create(nil);
img.Parent := ShowMouseClick;
img.Brush.Color := clGreen;
img.Shape := stCircle;
img.Width := 9;
img.Height := 9;
img.Left := Mouse.CursorPos.X-4;
img.Top := Mouse.CursorPos.Y-3;
snd.Tag := 1;
snd.Shape := img;
end else begin
snd.Enabled := false;
PostMessage(ShowMouseClick.Handle,WM_USER + 1545 , 0,0);
Application.ProcessMessages;
end;
end;
procedure TShowMouseClick.freeInactive(var Msg: TMessage);
var
i: integer;
begin
for i := timerList.Count - 1 downto 0 do
if TTimer2(timerList[i]).Enabled = false then
begin
TTimer2(timerList[i]).Free;
timerList.Delete(i);
end;
end;
destructor TTimer2.Destroy;
begin
FreeAndNil(FShape);
inherited;
end;
end.
Common unit.
unit HookCommon;
interface
uses Windows;
var
MouseHookMessage: Cardinal;
procedure HookMouse;
procedure UnHookMouse;
implementation
procedure HookMouse; external 'MouseHook.DLL';
procedure UnHookMouse; external 'MouseHook.DLL';
initialization
MouseHookMessage := RegisterWindowMessage('MouseHookMessage');
end.
DLL code.
library MouseHook;
uses
Forms,
Windows,
Messages,
HookCommon in 'HookCommon.pas';
{$J+}
const
Hook: HHook = 0;
{$J-}
{$R *.res}
function HookProc(nCode: Integer; MsgID: WParam; Data: LParam): LResult; stdcall;
var
notifyTestForm : boolean;
begin
notifyTestForm := false;
if msgID = $202 then
notifyTestForm := true;
if notifyTestForm then
begin
PostMessage(FindWindow('TShowMouseClick', nil), MouseHookMessage, MsgID, 0);
end;
Result := CallNextHookEx(Hook,nCode,MsgID,Data);
end;
procedure HookMouse; stdcall;
begin
if Hook = 0 then Hook:=SetWindowsHookEx(WH_MOUSE,#HookProc,HInstance,0);
end;
procedure UnHookMouse; stdcall;
begin
UnhookWindowsHookEx(Hook);
Hook:=0;
end;
exports
HookMouse, UnHookMouse;
begin
end.
The source of the mouse hook stuff is this
Why is it working fine when i click somewhere off my application form
but hangs when i click inside my form?
You're not posting the message to other windows when you click on them. First you should ask yourself, "what happens if I posted a message in my hook callback to all windows which are posted a WM_LBUTTONUP?".
Replace this line
PostMessage(FindWindow('TShowMouseClick', nil), MouseHookMessage, MsgID, 0);
in your dll code, with this:
PostMessage(PMouseHookStruct(Data).hwnd, MouseHookMessage, MsgID, 0);
It doesn't matter if the other applications would know or not what MouseHookMessage is, they will ignore the message. Launch your application and click the mouse wildly to other windows. Generally nothing will happen. Unless you click in the client area of any Delphi application. You'll instantly freeze it.
The answer to this question lies in both how a VCL message loop runs and how a WH_MOUSE hook works. A quote from MouseProc callback function's documentation.
[..] The system calls this function whenever an application calls the
GetMessage or PeekMessage function and there is a mouse message to be
processed.
Suppose you launch your application and the mouse is hooked, then you hover the mouse on your form and wait till your application calls 'WaitMessage', that it is idle. Now click in the client area to generate mouse messages. What happens is that the OS places messages to your application's main thread's message queue. And what your application does is that to remove and dispatch these messages with PeekMessage. This is where applications differ. The VCL first calls 'PeekMessage' with 'PM_NOREMOVE' passed in 'wRemoveMsg' parameter, while most other applications either removes the message with a call to 'PeekMessage' or do the same by using 'GetMessage'.
Now suppose it is 'WM_LBUTTONUP's turn. Refer to the quote above. As soon as PeekMessage is called, the OS calls the MouseProc callback. The call happens from 'user32.dll', that is, when your hook callback is called the statement following the 'PeekMessage' is not executed yet. Also, remember the VCL loop, the message is still in the queue, it has not been removed. Now, your callback function posts a message to the same message queue and returns. Execution returns to the VCL message loop and VCL again calls 'PeekMessage', this time to remove and dispatch the message, but instead of removing the 'WM_LBUTTONUP', it removes the custom message that you posted. 'WM_LBUTTONUP' remains in the queue. After the custom message is dispatched, since 'WM_LBUTTONUP' is still in the queue, 'PeekMessage' is again called, and again the OS calls the callback so that the callback can post another custom message to be removed instead of the mouse message. This loop effectively freezes the application.
To resolve, either post your message to a different thread that has its own message loop which would in some way synchronize with the main thread, or, I would not especially advice it but, instead of posting the message, send it. As an alternative you can remove the 'WM_LBUTTONUP' message yourself from the queue if one exists:
procedure TShowMouseClick.WndProc(var Message: TMessage);
begin
inherited WndProc(Message);
if (Message.Msg = HookCommon.MouseHookMessage) and
(Message.WParam = $202) then begin
if PeekMessage(Msg, Handle, WM_LBUTTONUP, WM_LBUTTONUP, PM_REMOVE) then
DispatchMessage(Msg); // or eat if you don't need it.
..
end;
The disadvantage to this approach is that, the PeekMessage itself, as mentioned above, will cause another custom message to be posted, so you'll be receiving those in pairs.
Either your Mouse click or your MyMessage messages are not removed from the Message Queue (unlikely) or they are somehow echoed back, or your code loops in a recursion.
I would try to remove any code from your TMyWindow.WndProc and replace it with some innocuous code (like an OutputDebugString to see it called in the message area of the IDE) to see if it is still looping or not.
Something like:
with Message do
case Msg of
WM_MyMessage: OutputDebugString('MyMessage received. Drawing a circle');
else
inherited WndProc(Message);
If it's only writing once per click, then the recursion is in your handling of the message (or in the timer handler) to draw/erase the circle.
If it's looping, then your click generates multiple messages or 1 that is spinning forever...
Update:
After giving a look at your code, I'd change the way you deal with the timers.
- Don't create the timer with an interval of 1 for the purpose of creating the shape. You'll be flooding your app with Timer events.
- As soon as you enter the Execute, disable the timer
- Avoid calling Application.ProcessMessages.
- You may have some reasons, but I find this very convoluted when it seems to me that a simple OnMouse event on your form could achieve this easily.
This happens because FindWindow actually sends messages on its own that also wind up in your hook. Specifically, it sends a WM_GETTEXT to get the window's title.
To avoid that, do the FindWindow up front (outside the hook's callback).

How to not have a MainForm in Delphi?

i've been trying to get some modeless forms in my application to appear on the taskbar - taking advantage of the new useful taskbar in Windows 7.
There's are many issues with the VCL that need to be undone before a form can exist on the taskbar.
But the final issue is that minimizing the form that the VCL has designated the main form causes all windows in the application to vanish.
Ten years ago, Peter Below (TeamB) documented these problems, and attempts to work around them. But there are some issues that cannot be solved. The issues run so deep within the VCL itself, that it's effectively impossible to make Delphi applications behave properly.
It all stems from the fact that the button you see on the toolbar does not represent the application's window; it represents the TApplications window, which is hidden and never seen. And then there is the application's MainForm, which is then imbued with special abilities where if it is minimized then it instructs the application to hide itself.
It seems to me that if i can do
Application.MainForm := nil;
then all these bugs would go away. The application can have its hidden window, and in the meantime i'll override every other form in the application, including my main form, with:
procedure TForm2.CreateParams(var params: TCreateParams );
begin
inherited CreateParams(params);
params.ExStyle := params.ExStyle or WS_EX_APPWINDOW;
end;
But in Delphi the Application.MainForm property is read-only.
How can i not have a MainForm in Delphi?
See also
(stackoverflow) Delphi: What is Application.Handle?
(newsgroup) Hiding Main Window but not child
You cannot run a GUI project without a MainForm assigned. The main message loop will exit immediately without one. However, that does not mean that the MainForm has to run your UI. You can use a blank hidden TForm as the assigned MainForm, and then have it instantiate your real MainForm as a secondary TForm. For example:
HiddenMainFormApp.dpr:
project HiddenMainFormApp;
uses
..., Forms, HiddenMainForm;
begin
Application.Initialize;
Application.CreateForm(THiddenMainForm, MainForm);
Application.ShowMainForm := False;
Application.Run;
end.
HiddenMainForm.cpp:
uses
..., RealMainForm;
procedure THiddenMainForm.FormCreate(Sender: TObject);
begin
RealMainForm := TRealMainForm.Create(Self);
RealMainForm.Show;
end;
RealMainForm.cpp:
procedure TRealMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
Application.Terminate;
end;
Alternatively:
HiddenMainFormApp.dpr:
project HiddenMainFormApp;
uses
..., Forms, HiddenMainForm, RealMainForm;
begin
Application.Initialize;
Application.CreateForm(THiddenMainForm, MainForm);
Application.ShowMainForm := False;
RealMainForm := TRealMainForm.Create(Application);
RealMainForm.Show;
RealMainForm.Update;
Application.Run;
end.
RealMainForm.cpp:
procedure TRealMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
Application.Terminate;
end;
You can't, especially in Delphi 5.
Your quote concerning the TApplication window being the one seen on the task bar hasn't been true for several Delphi versions now (I believe D2007 changed it).
Because you're using Delphi 5, you're using an outdated copy of Delphi; current versions have almost none of the things you're writing about any longer. I'd suggest you upgrade to a later version of Delphi (D5 is extremely old); Delphi 2007 if you need to avoid Unicode, Delphi XE if you can use (or don't mind having) Unicode support in the VCL and RTL.
The things you're describing are not bugs, BTW. They were intentional design decisions made at the time Delphi 1 was being designed, and through Delphi 7 worked fine with the versions of Windows that were available. Changes in later versions of Windows (XP/Vista/Win7 and the equivalent Server versions) made changes in that architecture necessary, and they were made as Delphi progressed along with Windows. Because you've chosen not to progress with your version of Delphi to keep it more recent doesn't make the things you write about magically become bugs. :-)
Having Application.MainForm assigned seems not to be a problem here for showing another modeless form on the taskbar while minimizing the MainForm.
Project1.dpr:
program Project1;
uses
Forms,
Windows,
Unit1 in 'Unit1.pas' {MainForm},
Unit2 in 'Unit2.pas' {Form2};
{$R *.res}
var
MainForm: TMainForm;
begin
Application.Initialize;
Application.CreateForm(TMainForm, MainForm);
ShowWindow(Application.Handle, SW_HIDE);
Application.Run;
end.
Unit1.pas:
unit Unit1;
interface
uses
Windows, Messages, Classes, Controls, Forms, StdCtrls, Unit2;
type
TMainForm = class(TForm)
ShowForm2Button: TButton;
ShowForm2ModalButton: TButton;
procedure ShowForm2ButtonClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure ShowForm2ModalButtonClick(Sender: TObject);
private
FForm2: TForm2;
procedure ApplicationActivate(Sender: TObject);
procedure Form2Close(Sender: TObject; var Action: TCloseAction);
procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;
protected
procedure CreateParams(var Params: TCreateParams); override;
end;
implementation
{$R *.dfm}
procedure TMainForm.FormCreate(Sender: TObject);
begin
Visible := True; //Required only for MainForm, can be set designtime
Application.OnActivate := ApplicationActivate;
end;
procedure TMainForm.ApplicationActivate(Sender: TObject);
{ Necessary in case of any modal windows dialog or modal Form active }
var
TopWindow: HWND;
I: Integer;
begin
TopWindow := 0;
for I := 0 to Screen.FormCount - 1 do
begin
Screen.Forms[I].BringToFront;
if fsModal in Screen.Forms[I].FormState then
TopWindow := Screen.Forms[I].Handle;
end;
Application.RestoreTopMosts;
if TopWindow = 0 then
Application.BringToFront
else
SetForegroundWindow(TopWindow);
end;
procedure TMainForm.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
begin
ExStyle := ExStyle or WS_EX_APPWINDOW;
WndParent := GetDesktopWindow;
end;
end;
procedure TMainForm.WMSysCommand(var Msg: TWMSysCommand);
begin
if Msg.CmdType = SC_MINIMIZE then
ShowWindow(Handle, SW_MINIMIZE)
else
inherited;
end;
{ Testing code from here }
procedure TMainForm.ShowForm2ButtonClick(Sender: TObject);
begin
if FForm2 = nil then
begin
FForm2 := TForm2.Create(Application); //Or: AOwner = nil, or Self
FForm2.OnClose := Form2Close;
end;
ShowWindow(FForm2.Handle, SW_RESTORE);
FForm2.BringToFront;
end;
procedure TMainForm.Form2Close(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
FForm2 := nil;
end;
procedure TMainForm.ShowForm2ModalButtonClick(Sender: TObject);
begin
with TForm2.Create(nil) do
try
ShowModal;
finally
Free;
end;
end;
end.
Unit2.pas:
unit Unit2;
interface
uses
Windows, Messages, Classes, Controls, Forms;
type
TForm2 = class(TForm)
private
procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;
protected
procedure CreateParams(var Params: TCreateParams); override;
end;
implementation
{$R *.dfm}
procedure TForm2.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
begin
ExStyle := ExStyle or WS_EX_APPWINDOW;
WndParent := GetDesktopWindow;
end;
end;
procedure TForm2.WMSysCommand(var Msg: TWMSysCommand);
begin
if Msg.CmdType = SC_MINIMIZE then
ShowWindow(Handle, SW_MINIMIZE)
else
inherited;
end;
end.
(Tested with D5 and D7 on XP and Win7.)
(And yes, you may flag this as being not an answer, because it isn't: There still is a MainForm. But I dó like to think this answers the question behind the question...)
I can't speak for Delphi 5, but in Delphi 7 you can definitely run without a mainform if you're willing to get your hands dirty. I covered a lot of the details in another answer here.
Since Delphi 5 doesn't have the MainFormOnTaskbar property, you need to do the following in your dpr:
// Hide application's taskbar entry
WasVisible := IsWindowVisible(Application.Handle);
if WasVisible then
ShowWindow(Application.Handle, SW_HIDE);
SetWindowLong(Application.Handle, GWL_EXSTYLE,
GetWindowLong(Application.Handle, GWL_EXSTYLE) or WS_EX_TOOLWINDOW);
if WasVisible then
ShowWindow(Application.Handle, SW_SHOW);
// Hide the hidden app window window from the Task Manager's
// "Applications" tab. Don't change Application.Title since
// it might get read elsewhere.
SetWindowText(Application.Handle, '');
That will hide the application window, and as long as you override your form's CreateParams to set Params.WndParent := 0 each of them will have a taskbar entry of their own. Application.MainForm isn't assigned, so things like the minimize override aren't an issue, but you do have to be careful about any code that assumes MainForm is valid.
You can put your modeless forms in a dll, then they act pretty much on their own. (If you do not use the Application instance of the dll while creating them (Application.CreateForm) then Application.Mainform is nil in the dll).
Of course this might not be feasible depending on what the forms might need to do.
Actually most of what you are complaining about is in fact the design of Windows rather than the VCL. See Windows Features for all the details.
The crux of the matter is the owner property, and I mean the windows owner rather than the VCL owner.
An owned window is hidden when
its owner is minimized.
If you wish to be able to minimise the main form without other windows being hidden then you need to get on top of how owned windows work.

Determine if running as VCL Forms or Service

I have code which is used both in services and within VCL Form applications (win32 application). How can I determine if the underlying application is running as a NT Service or as an application?
Thanks.
BEGIN OF EDIT
Since this still seems to be getting some attention I decided to update the answer with missing info and newer windows patches. In any case you should not copy / paste the code. The code is just a showcase on how the things should be done.
END OF EDIT:
You can check if the parent process is SCM (service control manager). If you are running as service this is always the case and never the case if running as standard application. Also I think that SCM has always the same PID.
You can check it like this:
type
TAppType = (atUnknown, atDesktop, atService);
var
AppType: TAppType;
function InternalIsService: Boolean;
var
PL: TProcessList;
MyProcessId: DWORD;
MyProcess: PPROCESSENTRY32;
ParentProcess: PPROCESSENTRY32;
GrandParentProcess: PPROCESSENTRY32;
begin
Result := False;
PL := TProcessList.Create;
try
PL.CreateSnapshot;
MyProcessId := GetCurrentProcessId;
MyProcess := PL.FindProcess(MyProcessId);
if MyProcess <> nil then
begin
ParentProcess := PL.FindProcess(MyProcess^.th32ParentProcessID);
if ParentProcess <> nil then
begin
GrandParentProcess := PL.FindProcess(ParentProcess^.th32ParentProcessID);
if GrandParentProcess <> nil then
begin
Result := SameText(string(ParentProcess^.szExeFile), 'services.exe') and
(SameText(string(GrandParentProcess^.szExeFile), 'winlogon.exe') or
SameText(string(GrandParentProcess^.szExeFile), 'wininit.exe'));
end;
end;
end;
finally
PL.Free;
end;
end;
function IsService: Boolean;
begin
if AppType = atUnknown then
begin
try
if InternalIsService then
AppType := atService
else
AppType := atDesktop;
except
AppType := atService;
end;
end;
Result := AppType = atService;
end;
initialization
AppType := atUnknown;
The TProcessList is implemented like this (again THashTable is not included but any hash table should be fine):
type
TProcessEntryList = class(TList)
private
function Get(Index: Integer): PPROCESSENTRY32;
procedure Put(Index: Integer; const Value: PPROCESSENTRY32);
public
property Items[Index: Integer]: PPROCESSENTRY32 read Get write Put; default;
function Add(const Entry: TProcessEntry32): Integer; reintroduce;
procedure Clear; override;
end;
TProcessList = class
private
ProcessIdHashTable: THashTable;
ProcessEntryList: TProcessEntryList;
public
constructor Create; reintroduce;
destructor Destroy; override;
procedure CreateSnapshot;
function FindProcess(const ProcessId: DWORD): PPROCESSENTRY32;
end;
implementation
{ TProcessEntryList }
procedure TProcessEntryList.Clear;
var
i: Integer;
begin
i := 0;
while i < Count do
begin
FreeMem(Items[i]);
Inc(i);
end;
inherited;
end;
procedure TProcessEntryList.Put(Index: Integer; const Value: PPROCESSENTRY32);
var
Item: Pointer;
begin
Item := inherited Get(Index);
CopyMemory(Item, Value, SizeOf(tagPROCESSENTRY32));
end;
function TProcessEntryList.Get(Index: Integer): PPROCESSENTRY32;
begin
Result := PPROCESSENTRY32(inherited Get(Index));
end;
function TProcessEntryList.Add(const Entry: TProcessEntry32): Integer;
var
EntryCopy: PPROCESSENTRY32;
begin
GetMem(EntryCopy, SizeOf(tagPROCESSENTRY32));
CopyMemory(EntryCopy, #Entry, SizeOf(tagPROCESSENTRY32));
Result := inherited Add(EntryCopy);
end;
{ TProcessList }
constructor TProcessList.Create;
begin
inherited;
ProcessEntryList := TProcessEntryList.Create;
ProcessIdHashTable := THashTable.Create;
end;
destructor TProcessList.Destroy;
begin
FreeAndNil(ProcessIdHashTable);
FreeAndNil(ProcessEntryList);
inherited;
end;
function TProcessList.FindProcess(const ProcessId: DWORD): PPROCESSENTRY32;
var
ItemIndex: Integer;
begin
Result := nil;
if not ProcessIdHashTable.ContainsKey(IntToStr(ProcessId)) then
Exit;
ItemIndex := Integer(ProcessIdHashTable.Item[IntToStr(ProcessId)]);
Result := ProcessEntryList.Items[ItemIndex];
end;
procedure TProcessList.CreateSnapshot;
var
SnapShot: THandle;
ProcessEntry: TProcessEntry32;
ItemIndex: Integer;
begin
SnapShot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if SnapShot <> 0 then
try
ProcessEntry.dwSize := SizeOf(ProcessEntry);
if Process32First(SnapShot, ProcessEntry) then
repeat
ItemIndex := ProcessEntryList.Add(ProcessEntry);
ProcessIdHashTable.Add(IntToStr(ProcessEntry.th32ProcessID), TObject(ItemIndex));
until not Process32Next(SnapShot, ProcessEntry);
finally
CloseHandle(SnapShot);
end;
end;
The application object (Forms.application) mainform will be nil if it is not a forms based application.
uses
Forms, ... ;
function IsFormBased : boolean;
begin
Result := Assigned(Forms.Application.MainForm);
end;
How about matching GetCurrentProcessId against EnumServicesStatusEx?
The lpServices parameter points to a buffer that receives an array of ENUM_SERVICE_STATUS_PROCESS structures.
The match is done against the enumerated service process ID: ServiceStatusProcess.dwProcessId in that structure.
Another option is using WMI to query for Win32_Service instances where ProcessId=GetCurrentProcessId.
I doubt that
System.IsConsole
System.IsLibrary
will give you the expected results.
All I can think of is to pass an Application object as TObject to the method where you need to make that distinction and test for the passed object's classname being a
TServiceApplication
or
TApplication
That said, there shouldn't be a need for you to know if your code is running in a service or a GUI. You should probably rethink your design and make the caller to pass an object to handle messages you want (or don't want) to show. (I assume it is for showing messages/exceptions you'd like to know).
You can try something like this
Function IsMyformInsideaWindowsService(aForm:TObject) :Boolean;
Begin
Result:=aForm.ClassParent.ClassName='TService'; //When a form is running under a service the Class Parent is a TService
End;
A single project cannot (or I should say ideally is not) both a service and a forms application, at least not if you are able to distinguish between the Forms Application object and the SvcMgr Application object - you must presumably have separate projects for the forms code and the service code.
So perhaps the easiest solution is a project conditional define. i.e. in your project settings for the service project add "SERVICEAPP" to the Conditional Defines.
Then whenever you need to change behaviour simply:
{$ifdef SERVICEAPP}
{$else}
{$endif}
For belts and braces you might adopt one of the previously described tests within some startup code to ensure that your project has been compiled with the expected symbol defined.
program ... ;
:
begin
{$ifdef SERVICEAPP}
// test for service app - ASSERT if not
{$else}
// test for forms app - ASSERT if not
{$endif}
:
end.
It is possible that your Forms app is actually running as a service, using the crude technique that allows any application to be running as a service.
In that case of course your app will always be a Forms application and the easiest way to handle that situation is to have a command line switch that you specify only in the service definition for your executable so that your app can respond appropriate by testing for that command line switch.
This does allow you to more easily test your "service mode" behaviour of course, since you can run your app in "debug" mode with that switch defined from within the IDE, but it's not an ideal way to build a service application so I would not recommend it on the strength of that alone. It's a technique that is usually only used when you have an EXE that you wish to run as a service but have no way to modify the source code to turn it into a "proper" service.
The answer from "Runner" ( https://stackoverflow.com/a/1568462 ) looked very helpful, but I could not use it since neither TProcessList, nor CreateSnapshot is defined. Searching for "TProcessList CreateSnapshot" in Google will just find 7 pages, including this one and mirrors/quotes of this page. No code exists. Alas, my reputation is too low to send him a comment, asking where I can find the code of TProcessList.
Another problem: At my computer (Win7 x64), the "services.exe" is NOT inside "winlogon.exe". It is inside "wininit.exe". Since it seems to be an implementation detail of Windows, I would suggest not querying the grand parent. Also, services.exe does not need to be the direct parent, since processes could be forked.
So this is my version using TlHelp32 directly, solving all the problems:
uses
Classes, TlHelp32;
function IsRunningAsService: boolean;
function FindProcess(FSnapshotHandle: THandle; PID: DWORD; var lppe: TProcessEntry32): boolean;
var
ContinueLoop: BOOL;
begin
ContinueLoop := Process32First(FSnapshotHandle, lppe);
while Integer(ContinueLoop) <> 0 do
begin
if lppe.th32ProcessID = PID then
begin
result := true;
Exit;
end;
ContinueLoop := Process32Next(FSnapshotHandle, lppe);
end;
result := false;
end;
var
CurProcessId: DWORD;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
ExeName, PrevExeName: string;
DeadlockProtection: TList<Integer>;
begin
Result := false;
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
DeadlockProtection := TList<Integer>.Create;
try
CurProcessId := GetCurrentProcessId;
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ExeName := '';
while FindProcess(FSnapshotHandle, CurProcessId, FProcessEntry32) do
begin
if DeadlockProtection.IndexOf(FProcessEntry32.th32ProcessID) > -1 then break;
DeadlockProtection.Add(FProcessEntry32.th32ProcessID);
PrevExeName := ExeName;
ExeName := FProcessEntry32.szExeFile;
(*
Result := SameText(PrevExeName, 'services.exe') and // Parent
SameText(ExeName, 'winlogon.exe'); // Grandparent
*)
Result := SameText(ExeName, 'services.exe'); // Parent
if Result then Exit;
CurProcessId := FProcessEntry32.th32ParentProcessID;
end;
finally
CloseHandle(FSnapshotHandle);
DeadlockProtection.Free;
end;
end;
This code works, also even in applications without MainForm (e.g. CLI apps).
you can use GetStdHandle method for get out console handle.when applications run as windows service has not output console.if GetStdHandle equals zero means your application run as windows service.
{$APPTYPE CONSOLE} // important
uses
uServerForm in 'uServerForm.pas' {ServerForm},
uWinService in 'uWinService.pas' {mofidWinServer: TService},
Windows,
System.SysUtils,
WinSvc,
SvcMgr,
Forms,etc;
function RunAsWinService: Boolean;
var
H: THandle;
begin
if FindCmdLineSwitch('install', ['-', '/'], True) then
Exit(True);
if FindCmdLineSwitch('uninstall', ['-', '/'], True) then
Exit(True);
H := GetStdHandle(STD_OUTPUT_HANDLE);
Result := H = 0;
end;
begin
if RunAsWinService then
begin
SvcMgr.Application.Initialize;
SvcMgr.Application.CreateForm(TmofidWinServer, mofidWinServer);
SvcMgr.Application.Run;
end
else
begin
Forms.Application.Initialize;
Forms.Application.CreateForm(TServerForm, ServerForm);
Forms.Application.Run;
end;
end.
I didn't find the simple answer which can be used easily and does not require recompilation and allows using one exe as a service and an application. You can install your program as a service with the command line parameter like “…\myapp.exe –s” and then check it from the program:
if ParamStr(ParamCount) = '-s' then
You can base the check on checking the session ID of the current process. All services runs with session ID = 0.
function IsServiceProcess: Boolean;
var
LSessionID, LSize: Cardinal;
LToken: THandle;
begin
Result := False;
LSize := 0;
if not OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, LToken) then
Exit;
try
if not GetTokenInformation(LToken, TokenSessionId, #LSessionID, SizeOf(LSessionID), LSize) then
Exit;
if LSize = 0 then
Exit;
Result := LSessionID = 0;
finally
CloseHandle(LToken);
end;
end;
I actually ended up checking the application.showmainform variable.
The problem with skamradt's isFormBased is that some of this code is called before the main form is created.
I am using a software library called SvCom_NTService from aldyn-software. One of purposes is for errors; either to log them or show a message. I totally agree with #Rob; our code should be better maintained and handle this outside of the functions.
The other intention is for failed database connections and queries; I have different logic in my functions to open queries. If it is a service then it will return nil but continue the process. But if failed queries/connections occur in an application then I would like to display a messaage and halt the application.
Check if your Applicatoin is an instance of TServiceApplication:
IsServiceApp := Application is TServiceApplication;

Resources