Is there a way to Minimize an external application that I don't have control over from with-in my Delphi application?
for example notepad.exe, except the application I want to minimize will only ever have one instance.
You can use FindWindow to find the application handle and ShowWindow to minimize it.
var
Indicador :Integer;
begin
// Find the window by Classname
Indicador := FindWindow(PChar('notepad'), nil);
// if finded
if (Indicador <> 0) then begin
// Minimize
ShowWindow(Indicador,SW_MINIMIZE);
end;
end;
I'm not a Delphi expert, but if you can invoke win32 apis, you can use FindWindow and ShowWindow to minimize a window, even if it does not belong to your app.
Thanks for this, in the end i used a modifyed version of Neftali's code, I have included it below in case any one else has the same issues in the future.
FindWindow(PChar('notepad'), nil);
was always returning 0, so while looking for a reason why I found this function that would find the hwnd, and that worked a treat.
function FindWindowByTitle(WindowTitle: string): Hwnd;
var
NextHandle: Hwnd;
NextTitle: array[0..260] of char;
begin
// Get the first window
NextHandle := GetWindow(Application.Handle, GW_HWNDFIRST);
while NextHandle > 0 do
begin
// retrieve its text
GetWindowText(NextHandle, NextTitle, 255);
if Pos(WindowTitle, StrPas(NextTitle)) <> 0 then
begin
Result := NextHandle;
Exit;
end
else
// Get the next window
NextHandle := GetWindow(NextHandle, GW_HWNDNEXT);
end;
Result := 0;
end;
procedure hideExWindow()
var Indicador:Hwnd;
begin
// Find the window by Classname
Indicador := FindWindowByTitle('MyApp');
// if finded
if (Indicador <> 0) then
begin
// Minimize
ShowWindow(Indicador,SW_HIDE); //SW_MINIMIZE
end;
end;
I guess FindWindow(PChar('notepad'), nil) should be FindWindow(nil, PChar('notepad')) to find the window by title.
Related
I've a problem with using DirectX (DirectSound) on Windows 10. I'me changing some legacy code that used DirectX (DirectX 9 I think) and run on Windows XP.
Everything is still working great on Windows XP but I can't get a sound on Windows 10.
The application uses these files: DXUTIL.PAS (Original ObjectPascal conversion made by: Boris V.), lzexpand.pas (Author: Vadim Bodrov) and DirectSound.pas (DirectX 9.0 Delphi / FreePascal adaptation by Alexey Barkovoy).
procedure TForm1.Button1Click(Sender: TObject);
var
sndgwait : PSound;
begin
InitSB(Handle);
LoadWave(sndgwait, 'D:\game\EXP01.wav', 1);
StartSound(sndgwait, false);
end;
function LoadWave(var Sound: PSound; fn : string; conc : integer) : boolean;
var
cbData, cbdata1 : DWORD;
pd1 : pointer;
hfile : longint;
vreopenbuff : TOFStruct;
begin
hfile := LZOpenFile(PAnsiChar(fn), vreopenbuff, OF_READ);
if hfile < 0 then begin result := false; exit; end;
cbdata := LZSeek(hfile, 0, 2); // file size
LZSeek(hfile, 0, 0); //back to the start of the wav
getmem(pd1, cbdata);
LZRead(hfile, pd1, cbdata);
LZClose(hfile);
if conc < 1 then conc := 1;
result := ParseWaveData(Sound, conc, cbdata, pd1);
end;
function ParseWaveData(var Sound : PSound; conc : integer; cbdata : dword; pd1 : pointer) : boolean;
var
pWaveHeader: PWAVEFORMATEX;
pDSB: IDirectSoundBuffer;
dsBD: TDSBUFFERDESC;
rr : longint;
begin
if lpDS = nil then begin
result := false;
exit;
end;
Sound := PSNDOBJ(LocalAlloc(LPTR, SizeOf(TSNDOBJ) + (conc-1) * SizeOf(IDirectSoundBuffer)));
Sound^.iAlloc := conc;
Sound^.cbWaveSize := 0;
Sound^.pbWaveData := nil;
pwaveHeader := nil;
Sound^.pbData := pd1;
Sound^.cbSize := cbdata;
if DSParseWaveResource(pd1, pWaveHeader, Sound^.pbWaveData, Sound^.cbWaveSize) then begin
ZeroMemory(#dsBD, SizeOf(dsBD));
dsBD.dwSize := SizeOf(dsBD);
dsBD.dwFlags := DSBCAPS_STATIC or DSBCAPS_GETCURRENTPOSITION2 or DSBCAPS_CTRLFREQUENCY orDSBCAPS_CTRLPAN or DSBCAPS_CTRLVOLUME;//DSBCAPS_CTRLDEFAULT or
dsBD.lpwfxFormat := pWaveHeader;
dsBD.dwBufferBytes := Sound^.cbWaveSize;
if lpDS.CreateSoundBuffer(dsBD, pDSB, nil) = DS_OK then begin
if not DSFillSoundBuffer(pDSB, Sound^.pbWaveData, dsBD.dwBufferBytes) then begin
pDSB._Release;
pDSB := nil;
end;
Sound^.Buffers[0] := pDSB;
for rr := 1 to conc - 1 do begin
lpDS.DuplicateSoundBuffer(Sound^.Buffers[0], Sound^.Buffers[rr]);
end;
end else begin
pDSB := nil;
SndObjDestroy(Sound);
Sound := nil;
end;
end;
Result := Sound <> nil;
end;
function StartSound(Sound: PSound; Loop: boolean = false; waitforend: boolean = false): boolean;
begin
if Loop then
StartSound := SndObjPlay(Sound, DSBPLAY_LOOPING)
else
StartSound := SndObjPlay(Sound, 0);
if waitforend and not loop then
while SoundPlaying(Sound) do Application.ProcessMessages;
end;
function SndObjPlay(pSO: PSNDOBJ; dwPlayFlags: DWORD): Boolean;
var
pDSB: IDirectSoundBuffer;
begin
Result := FALSE;
if pSO = nil then
begin
exit;
end;
if ((dwPlayFlags and DSBPLAY_LOOPING) = 0) or (pSO^.iAlloc = 1) then
begin
pDSB := SndObjGetFreeBuffer(pSO);
if (pDSB <> nil) then
Result := SUCCEEDED(pDSB.Play(0, 0, dwPlayFlags));
end else
Result:= FALSE;
end;
All values in ParseWaveData call are correct I think (no nil values).
I'm not gething any errors. Just there is no sound.
What can be a problem here?
Or are there other ways to use DirectX for sound in this old app on windows 10? Any example would be great.
Thanks....
While I cannot guarantee this is the fix, I also cannot just comment because I don't have 50 rep, it is worth a try. I had a lot of issues with Windows 10 sound, often it seemed at random! Switching apps disabled sound from background apps, game programming wouldn't make a peep, even playing music to see if I had the right track with CD burning software was broken, Netflix breaking sound until I rebooted, wireless headphones not working or volume way too low. Infuriating. You might not be wrestling control from whatever has current priority because of an W10 April 2018 change and just not had the issues I've had.
Anyway, this is worth a try:
Right-click the Sound Icon in the bottom right of task bar. Click
Playback or Audio Devices. Right-click the speaker icon that appears
in the settings screen. Click Properties from the pop-up menu. Click
the Advanced tab on the Speakers Properties screen. Uncheck the boxes
for Allow applications to take exclusive control and Give exclusive
mode applications priority.
I've solved this. At the end it wasn't anything with DirectX.
hfile := LZOpenFile(PAnsiChar(fn), vreopenbuff, OF_READ);
Parameter "fn" (string) that was input to the procedure was wrong. Something messes up. The file name was incorrect, so file that should be played was empty. Nothing to do with DirectX. I've replaced above command with:
hfile := LZOpenFile(PAnsiChar(AnsiString(fn)), vreopenbuff, OF_READ);
Now it is working.
Thanks...
I'm developing application that is using Mifare Classic 1K card and HID Omnikey 5421 (successor of 5321). I using thread to detect card remove/insert.
Delphi code (thread method):
function CardWatcherThread(PContext: Pointer): integer;
var
RetVar : cardinal;
RContext : cardinal;
RStates : array[0..0] of SCARD_READERSTATEA;
begin
try
RContext := Cardinal(PContext^);
FillChar(RStates,SizeOf(RStates),#0);
RStates[0].szReader := SelectedReader;
RStates[0].pvUserData := nil;
RStates[0].dwCurrentState := SCARD_STATE_UNAWARE;
while ReaderOpen and (not Application.Terminated) do begin
RetVar := SCardGetStatusChange(RContext, MAX_WAIT_TIME_SCARDSTATUSCHANGE, #RStates, 1);
RStates[0].dwCurrentState := RStates[0].dwEventState;
ActReaderState := RStates[0].dwEventState;
// Avoid sedning error about timemout if MAX_WAIT_TIME_SCARDSTATUSCHANGE is not infinite
if (RetVar <> SCARD_E_TIMEOUT) or (MAX_WAIT_TIME_SCARDSTATUSCHANGE = -1) then begin
SendMessage(NotifyHandle, WM_CARDSTATE, RetVar, 0);
end;
end;
finally
Result := 0;
end;
end;
I'm using SendMessage to notify my Smart Card class where I'm detecting proper state. Also I automatically connect and read data from smart card when I detect card insertion.
My application is working correctly for most of the time, but sometimes for e.g. once in the 10000 of card insertion I'm getting SCARD_F_INTERNAL_ERROR from SCardGetStatusChange. When this happen SCardGetStatusChange is starting to result only SCARD_F_INTERNAL_ERROR all the time. When I detected this situation I tried to SCardCancel and SCardReleaseContext, end thread and establish new context and create new watcher thread with this new context but this is not helping because SCardGetStatusChange was continue to returning SCARD_F_INTERNAL_ERROR. Only when I close application and run again problem disappears.
It's happening randomly for me, I can't reproduce it using some known scenario. In PC can be more readers, but I'm establishing connection only to Omnikey 5421.
Someone met with this problem?
It's hard to say what goes wrong but I have few remarks about your code, hope they help...
you should check the return value of the SCardGetStatusChange as the first thing and if it is SCARD_E_TIMEOUT then just skip all the processing and start next cycle;
instead of just RStates[0].dwCurrentState := RStates[0].dwEventState; you also have to clear out the SCARD_STATE_CHANGED bit from the state (that is, if the state actually changed);
it is my understanding that the resource manager context might become invalid, so before calling SCardGetStatusChange use SCardIsValidContext to make sure you still have good context, if not acquire new one;
So try something like this (this is typed to the browser, so untestead and probably wont compile as is):
function CardWatcherThread(PContext: Pointer): integer;
var
RetVar : cardinal;
RContext : cardinal;
RStates : array[0..0] of SCARD_READERSTATEA;
begin
try
RContext := Cardinal(PContext^);
FillChar(RStates,SizeOf(RStates),#0);
RStates[0].szReader := SelectedReader;
RStates[0].pvUserData := nil;
RStates[0].dwCurrentState := SCARD_STATE_UNAWARE;
while ReaderOpen and (not Application.Terminated) do begin
if(SCardIsValidContext(RContext) <> SCARD_S_SUCCESS)then begin
RetVal := SCardEstablishContext(...);
end;
RetVar := SCardGetStatusChange(RContext, MAX_WAIT_TIME_SCARDSTATUSCHANGE, #RStates, 1);
case RetVal of
SCARD_E_TIMEOUT:;
SCARD_S_SUCCESS: begin
if((RStates[0].dwEventState and SCARD_STATE_CHANGED) <> 0)then begin
RStates[0].dwCurrentState := RStates[0].dwEventState xor SCARD_STATE_CHANGED;
// reader's state changed, do something
end;
end;
end;
end;
finally
Result := 0;
end;
end;
I hope this post is not a duplicate one. Let me explain:
I have considered the similar post How to pause / resume any external process under Windows? but with C++/Python preference and yet without an accepted answer as of the time of posting.
My Question:
I'm interested in a possible implementation in Delphi of the functionality provided by PsSuspend by Mark Russinovich of Windows Sysinternals.
Quotes:
PsSuspend lets you suspend processes on the local or a remote system,
which is desirable in cases where a process is consuming a resource
(e.g. network, CPU or disk) that you want to allow different processes
to use. Rather than kill the process that's consuming the resource,
suspending permits you to let it continue operation at some later
point in time.
Thank you.
Edit:
A partial implementation will do. Remote capability can be dropped.
You can try to use the following code. It uses the undocumented functions NtSuspendProcess and NtResumeProcess. I've tried it on Windows 7 64-bit from the 32-bit application built in Delphi 2009 and it works for me. Note that these functions are undocumented thus can be removed from future versions of Windows.
Update
The SuspendProcess and ResumeProcess wrappers from the following code are now functions and returns True if succeed, False otherwise.
type
NTSTATUS = LongInt;
TProcFunction = function(ProcHandle: THandle): NTSTATUS; stdcall;
const
STATUS_SUCCESS = $00000000;
PROCESS_SUSPEND_RESUME = $0800;
function SuspendProcess(const PID: DWORD): Boolean;
var
LibHandle: THandle;
ProcHandle: THandle;
NtSuspendProcess: TProcFunction;
begin
Result := False;
LibHandle := SafeLoadLibrary('ntdll.dll');
if LibHandle <> 0 then
try
#NtSuspendProcess := GetProcAddress(LibHandle, 'NtSuspendProcess');
if #NtSuspendProcess <> nil then
begin
ProcHandle := OpenProcess(PROCESS_SUSPEND_RESUME, False, PID);
if ProcHandle <> 0 then
try
Result := NtSuspendProcess(ProcHandle) = STATUS_SUCCESS;
finally
CloseHandle(ProcHandle);
end;
end;
finally
FreeLibrary(LibHandle);
end;
end;
function ResumeProcess(const PID: DWORD): Boolean;
var
LibHandle: THandle;
ProcHandle: THandle;
NtResumeProcess: TProcFunction;
begin
Result := False;
LibHandle := SafeLoadLibrary('ntdll.dll');
if LibHandle <> 0 then
try
#NtResumeProcess := GetProcAddress(LibHandle, 'NtResumeProcess');
if #NtResumeProcess <> nil then
begin
ProcHandle := OpenProcess(PROCESS_SUSPEND_RESUME, False, PID);
if ProcHandle <> 0 then
try
Result := NtResumeProcess(ProcHandle) = STATUS_SUCCESS;
finally
CloseHandle(ProcHandle);
end;
end;
finally
FreeLibrary(LibHandle);
end;
end;
There is no SuspendProcess API call in Windows. So what you need to do is:
Enumerate all the threads in the process. See RRUZ's answer for sample code.
Call SuspendThread for each of these threads.
In order to implement the resume part of the program, call ResumeThread for each thread.
There is a race condition for the "suspend all threads" implementation - what happens if the program you are trying to suspend creates one or more threads between the time that you create the snapshot and the time that you complete suspending?
You could loop, getting another snapshot and suspending any unsuspending threads, exiting only when you found none.
The undocumented function avoids this issue.
I just found the following snippets here (Author: steve10120).
I think they are valuables and I can't help posting them also as an alternative answer to my own question.
Resume Process:
function ResumeProcess(ProcessID: DWORD): Boolean;
var
Snapshot,cThr: DWORD;
ThrHandle: THandle;
Thread:TThreadEntry32;
begin
Result := False;
cThr := GetCurrentThreadId;
Snapshot := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);
if Snapshot <> INVALID_HANDLE_VALUE then
begin
Thread.dwSize := SizeOf(TThreadEntry32);
if Thread32First(Snapshot, Thread) then
repeat
if (Thread.th32ThreadID <> cThr) and (Thread.th32OwnerProcessID = ProcessID) then
begin
ThrHandle := OpenThread(THREAD_ALL_ACCESS, false, Thread.th32ThreadID);
if ThrHandle = 0 then Exit;
ResumeThread(ThrHandle);
CloseHandle(ThrHandle);
end;
until not Thread32Next(Snapshot, Thread);
Result := CloseHandle(Snapshot);
end;
end;
Suspend Process:
function SuspendProcess(PID:DWORD):Boolean;
var
hSnap: THandle;
THR32: THREADENTRY32;
hOpen: THandle;
begin
Result := FALSE;
hSnap := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);
if hSnap <> INVALID_HANDLE_VALUE then
begin
THR32.dwSize := SizeOf(THR32);
Thread32First(hSnap, THR32);
repeat
if THR32.th32OwnerProcessID = PID then
begin
hOpen := OpenThread($0002, FALSE, THR32.th32ThreadID);
if hOpen <> INVALID_HANDLE_VALUE then
begin
Result := TRUE;
SuspendThread(hOpen);
CloseHandle(hOpen);
end;
end;
until Thread32Next(hSnap, THR32) = FALSE;
CloseHandle(hSnap);
end;
end;
Disclaimer:
I didn't test them at all. Please enjoy and don't forget to feedback.
I am implementing context sensitive help in my Delphi 2009 application. It works fine except in one case. I cannot identify that I am in the main menu, and which menu item has been opened.
What I want to do is if the user has opened the File menu and while its open presses F1, then I'll bring up my help on the File menu. If they open the Edit menu and press F1, then I'll bring up my help on the Edit menu, etc.
I am using ApplicationEventsHelp to process the user's pressing of F1 as follows:
function MainForm.ApplicationEvents1Help(Command: Word; Data: Integer;
var CallHelp: Boolean): Boolean;
begin
if Command = HELP_COMMAND then begin
Application.HelpSystem.ShowTopicHelp(PChar(Data), Application.CurrentHelpFile);
CallHelp := false;
end;
Result := true;
end;
As I mentioned, this works for everything except the main menu. I've tried using
FindVCLWindow(Mouse.CursorPos)
and other such methods that identify the active control to see if they would identify the menu, but they don't seem to.
Is there a way to tell which menu item (if any) is open when the F1 key is pressed?
Thank you everyone for your help and good ideas.
Just to document my final solution, I found that the system is not particularly good at figuring out which control it is in and sometimes gets it wrong and passes incorrect data to ApplicationEventsHelp which brings up an inappropriate help page.
After experimenting and using the solution for handling the menus in the accepted answer, I found it was best to identify which control I was in to bring up the correct help item. I ended up not even using the HelpKeyword property, but hardcoding it. The code is clear and it works. I also have my the help for my RVEdit window bringing up different help pages depending on the section of the document you are in (my CurCursorID tells me that).
For anyone who wants to do this like I did, here is how:
function TLogoAppForm.ApplicationEvents1Help(Command: Word; Data: Integer;
var CallHelp: Boolean): Boolean;
var
HelpKeyword: string;
SType: string;
begin
if Command = HELP_COMMAND then begin
if PtInRect(RVEdit.ClientRect, RVEdit.ScreenToClient(Mouse.CursorPos)) then begin
if CurCursorID = 'H' then HelpKeyword := 'RefTopReport'
else if CurCursorID = 'T' then HelpKeyword := 'RefTableContents'
else if CurCursorID = '~HNAME' then HelpKeyword := 'RefIndexNames'
else if copy(CurCursorID, 1, 2) = 'N+' then HelpKeyword := 'RefIndexNames'
else if CurCursorID = 'B' then HelpKeyword := 'RefBottomReport'
else if CurCursorID <> '' then HelpKeyword := 'RefInformationArea'
else HelpKeyword := 'RefEverythingReport';
Application.HelpSystem.ShowTopicHelp(HelpKeyword, Application.CurrentHelpFile);
end
else if PtInRect(ElTree.ClientRect, ElTree.ScreenToClient(Mouse.CursorPos)) then
Application.HelpSystem.ShowTopicHelp('RefTreeView', Application.CurrentHelpFile)
else if PtInRect(TopToolbar.ClientRect, TopToolbar.ScreenToClient(Mouse.CursorPos)) then
Application.HelpSystem.ShowTopicHelp('RefTopToolbar', Application.CurrentHelpFile)
else if PtInRect(BottomToolbar.ClientRect, BottomToolbar.ScreenToClient(Mouse.CursorPos)) then
Application.HelpSystem.ShowTopicHelp('RefBottomToolbar', Application.CurrentHelpFile)
else
Application.HelpSystem.ShowTopicHelp('RefMainWindow', Application.CurrentHelpFile);
CallHelp := false;
end
else if Command = HELP_CONTEXTPOPUP then begin
case Data of
0: HelpKeyword := 'RefMenuBar';
11: HelpKeyword := 'RefFileMenu';
12: HelpKeyword := 'RefEditMenu';
13: HelpKeyword := 'RefSearchMenu';
14: HelpKeyword := 'RefNavigateMenu';
15: HelpKeyword := 'RefViewMenu';
16: HelpKeyword := 'RefOrganizeMenu';
17: HelpKeyword := 'RefHelpMenu';
else HelpKeyword := '';
end;
if HelpKeyword <> '' then begin
Application.HelpSystem.ShowTopicHelp(HelpKeyword, Application.CurrentHelpFile);
CallHelp := false;
end;
end;
Result := true;
end;
I did have to put 11 through 17 into the HelpContext property of the MenuItems in my 7 main menus so that the correct help would come up depending on which menu you were in. The detection of the menu item is the help the answer to this question provided me.
The nice thing is that this code is easy to follow (using HelpKeywords instead of HelpContext numbers) and will probably still work even after conversion to Delphi XE and FireMonkey.
Looking at Command = HELP_COMMAND and the cast of Data to PChar, it seems you work with a help system based on keywords rather then on context identifiers (HelpType = htKeyword).
(Here in Delphi 7) Menu items do not have the HelpType and HelpKeyword properties, so you are bound to use the HelpContext property:
function TForm1.ApplicationEvents1Help(Command: Word; Data: Integer;
var CallHelp: Boolean): Boolean;
begin
if Command = HELP_COMMAND then
begin
//Application.HelpSystem.ShowTopicHelp(PChar(Data), Application.CurrentHelpFile);
//Doesn't this do the same?
Application.HelpKeyword(PChar(Data));
CallHelp := False;
end
else if Command = HELP_CONTEXT then
begin
// Convert the context identifier to your keyword, or:
Application.HelpContext(Data);
CallHelp := False;
end;
Result := True;
end;
By trapping windows message 'WM_MENUSELECT' it is possible to keep track of the selected menu item.
See menuitemhints for more information.
Example :
type
TForm1 = class(TForm)
...
private
fMyCurrentSelectedMenuItem : TMenuItem;
procedure WMMenuSelect(var Msg: TWMMenuSelect) ; message WM_MENUSELECT;
end
procedure TForm1.WMMenuSelect(var Msg: TWMMenuSelect) ;
var
menuItem : TMenuItem;
hSubMenu : HMENU;
begin
inherited; // from TCustomForm (so that Application.Hint is assigned)
menuItem := nil;
if (Msg.MenuFlag <> $FFFF) or (Msg.IDItem <> 0) then
begin
if Msg.MenuFlag and MF_POPUP = MF_POPUP then
begin
hSubMenu := GetSubMenu(Msg.Menu, Msg.IDItem) ;
menuItem := Self.Menu.FindItem(hSubMenu, fkHandle) ;
end
else
begin
menuItem := Self.Menu.FindItem(Msg.IDItem, fkCommand) ;
end;
end;
//miHint.DoActivateHint(menuItem) ;
fMyCurrentSelectedMenuItem := menuItem;
end; (*WMMenuSelect*)
So when the F1 button is pressed you can use the fMyCurrentSelectedMenuItem to activate the correct help.
You can use GetMenuItemRect function:
1. Go through all items in your main menu and call GetMenuItemRect to get item position. Function will work only if item is displayed.
2. Use GetCursorPos and PtInRect to check if mouse is over menu item and call appropriate help topic.
I execute exe file by CreateProcess() and set foreground process by SetForegroundWindow().
but it doesn't work in Win7 so I have to click icon in taskbar.
How can I implement the behaviour I want (which is to Launch and BringToForeground)?
You shouldn't even try to do this. The change in SetForegroundWindow was intentional - it prevents applications from stealing the focus from what the user wants to have focus. See the Remarks section of the link above.
Win7 probably won't let non-administrative users change the needed registry setting, much less do it without a restart of the system.
You should just use FlashWindow instead to get the user's attention, as Microsoft recommends. Any application that insists on stealing focus away from what I choose to do will be uninstalled immediately.
I was going to post a link (in a comment) to a piece of code that I once had to apply to solve a problem of my own. The link has turned out to be broken now, so I'm posting the code here for what it's worth (it has been tested in Windows XP Pro SP2 and Windows Server 2003, but not in Windows 7):
function ForceForegroundWindow(hwnd: THandle): boolean;
{
found here:
http://delphi.newswhat.com/geoxml/forumhistorythread?groupname=borland.public.delphi.rtl.win32&messageid=501_3f8aac4b#newsgroups.borland.com
}
const
SPI_GETFOREGROUNDLOCKTIMEOUT = $2000;
SPI_SETFOREGROUNDLOCKTIMEOUT = $2001;
var
ForegroundThreadID: DWORD;
ThisThreadID: DWORD;
timeout: DWORD;
begin
if IsIconic(hwnd) then ShowWindow(hwnd, SW_RESTORE);
if GetForegroundWindow = hwnd then Result := true
else begin
// Windows 98/2000 doesn't want to foreground a window when some other
// window has keyboard focus
if ((Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion > 4)) or
((Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and ((Win32MajorVersion > 4) or
((Win32MajorVersion = 4) and (Win32MinorVersion > 0)))) then begin
// Code from Karl E. Peterson, www.mvps.org/vb/sample.htm
// Converted to Delphi by Ray Lischner
// Published in The Delphi Magazine 55, page 16
Result := false;
ForegroundThreadID := GetWindowThreadProcessID(GetForegroundWindow,nil);
ThisThreadID := GetWindowThreadPRocessId(hwnd,nil);
if AttachThreadInput(ThisThreadID, ForegroundThreadID, true) then
begin
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hwnd);
AttachThreadInput(ThisThreadID, ForegroundThreadID, false); // bingo
Result := (GetForegroundWindow = hwnd);
end;
if not Result then begin
// Code by Daniel P. Stasinski
SystemParametersInfo(SPI_GETFOREGROUNDLOCKTIMEOUT, 0, #timeout, 0);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(0), SPIF_SENDCHANGE);
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hWnd);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(timeout), SPIF_SENDCHANGE);
end;
end
else begin
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hwnd);
end;
Result := (GetForegroundWindow = hwnd);
end;
end; { ForceForegroundWindow }
end.
I didn't add anything to the function apart from a small comment 'bingo', which marks the line which actually brought about the desired effect.
Just so you guys didn't think I was abusing users' experience with this function, here's some explanation.
This function was used in an application that was called remotely with the help of Citrix software set up on users' Tablet PCs, and the application ran in full screen. A typical working session almost entirely consisted of that application (other parts were just system components which user never interacted with).
Now some parts of our application had to be implemented as separate small applications, and they were designed to stay on top of all other windows until closed, just like modal windows. Once in a while they used to lose their Z order and hide under the main application's main window, and that was a total disaster for users. Using the 'top-most' property wasn't an option there, so we had to find a way to sustain their Z-order positions. And so we used this function.
ForceForegroundWindow worked for me in Win10. However, it does not activate the external program. It only makes it visible and on top. The program also only does the same when calling itself. I am assuming that if it activated it would also setfocus appropriately for the user.
Rick
I found a resolution for activating and setting focus... In the "SetAppRestore" procedure I initiated it with "MainFrm.visible:= false". Then it goes to SwitchApp, and it calls ForceForegroundWindow. After it returns to "SetAppRestore", I inserted "MainFrm.visible:= true". This triggered the app to become active and have focus on defined component: DataPge.SetFocus.
I apologize for not placing the code in a code block. I couldn't understand the instructions. So I put it all between 2 ===== bars.
//==========================
function TMainFrm.FindWindowExtd(partialTitle: string): HWND; // get with wildcard
var // by Dorin Duminica, September 10, 2009
hWndTemp: hWnd;
iLenText: Integer;
cTitletemp: array [0..254] of Char;
sTitleTemp: string;
begin
hWndTemp := FindWindow(nil, nil);
while hWndTemp <> 0 do
begin
iLenText := GetWindowText(hWndTemp, cTitletemp, 255);
sTitleTemp := cTitletemp;
sTitleTemp := UpperCase(copy( sTitleTemp, 1, iLenText));
partialTitle := UpperCase(partialTitle);
if pos(partialTitle, sTitleTemp) <> 0 then Break;
hWndTemp := GetWindow(hWndTemp, GW_HWNDNEXT);
end;
result := hWndTemp;
end;
function ForceForegroundWindow(hwnd: THandle): boolean;
const
SPI_GETFOREGROUNDLOCKTIMEOUT = $2000;
SPI_SETFOREGROUNDLOCKTIMEOUT = $2001;
var
ForegroundThreadID: DWORD;
ThisThreadID: DWORD;
timeout: DWORD;
begin
if IsIconic(hwnd) then ShowWindow(hwnd, SW_RESTORE);
if GetForegroundWindow = hwnd
then Result:= true
else begin
// Windows 98/2000 doesn't want to foreground a window when some other
// window has keyboard focus
if ((Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion > 4)) or
((Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and ((Win32MajorVersion > 4) or
((Win32MajorVersion = 4) and (Win32MinorVersion > 0)))) then
begin
// Code from Karl E. Peterson, www.mvps.org/vb/sample.htm
// Converted to Delphi by Ray Lischner
// Published in The Delphi Magazine 55, page 16
Result:= false;
ForegroundThreadID:= GetWindowThreadProcessID(GetForegroundWindow,nil);
ThisThreadID:= GetWindowThreadPRocessId(hwnd,nil);
if AttachThreadInput(ThisThreadID, ForegroundThreadID, true) then
begin
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hwnd);
AttachThreadInput(ThisThreadID, ForegroundThreadID, false); // bingo
Result:= (GetForegroundWindow = hwnd);
//showmessage('case 1');
end;
if not Result then
begin
// Code by Daniel P. Stasinski
SystemParametersInfo(SPI_GETFOREGROUNDLOCKTIMEOUT, 0, #timeout, 0);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(0), SPIF_SENDCHANGE);
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hWnd);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(timeout), SPIF_SENDCHANGE);
//showmessage('case 2');
end;
end
else begin
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hwnd);
//showmessage('case 3');
end;
Result:= (GetForegroundWindow = hwnd);
end;
end; { ForceForegroundWindow }
procedure TMainFrm.SwitchApp(AppCaption:string); // application.restore;
begin
//TmpAppHandle:= FindWindow(nil, PChar(AppCaption)); // uses Windows unit - must be entire caption
TmpAppHandle:= FindWindowExtd(AppCaption); // finds 'notepad' as partial of 'Document - Notepad'
if (TmpAppHandle<>0)
then begin
//SetForegroundWindow(TmpAppHandle); // worked by itself for WinXP and Win7
ForceForegroundWindow(TmpAppHandle);
end
else ShowAlert(AppCaption+' *not found*');
end;
// application.restore can't restore from MainForm.windowstate:=wsMinimized
// SetAppMinimize and SetAppRestore fix that issue and manual minimizations
procedure TMainFrm.SetAppMinimize; // application.minimize
begin
if not(MainFrm.WindowState=wsMinimized) then
begin
MainFrm.WindowState:= wsMinimized;
end;
SwitchApp(ServerName); // autocad or bricscad
end;
procedure TMainFrm.SetAppRestore; // application.restore
begin
MainFrm.visible:= false; // ** to reinsate and focus in win10 **
if (MainFrm.WindowState=wsMinimized) then
begin
MainFrm.WindowState:= wsNormal;
end;
SwitchApp('CmdData'); // partial string for app title
MainFrm.visible:= true; // ** to reinsate and focus in win10 **
FormatGrid; // added for activex crash
DataPge.SetFocus;
Update;
end;
//==========================