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...
Related
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 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;
//==========================
Is there support in the Delphi XE VCL for ensuring only a single instance of an application is running?
In the past, I've used library code to control a Mutex which has always seemed complicated. As I'm starting a new project in Delphi XE, I wonder if I need to dig up that old code, or if there is support built into XE already? Or is there another easy to apply code that is nice and modern?
You create a named Mutex when you start the application. Check GetLastError to see if an other instance is already running.
Put this code right after "begin" in your DPR file. Replace the GUID with one of your own. When I need a text constant that's unlikely to be used for anything else, I usually just hit Ctrl+G to get a GUID!
if CreateMutex(nil, True, '6EACD0BF-F3E0-44D9-91E7-47467B5A2B6A') = 0 then
RaiseLastOSError;
if GetLastError = ERROR_ALREADY_EXISTS then
Exit;
It might look like the code is leaking an handle because it's not saving the return of CreateMutex. It's not. Windows will automatically release the handle when our application is terminated, and that's absolutely fine with us.
I use JCL to do this:
program MyProgram;
uses
JclAppInst;
begin
JclAppInstances.CheckSingleInstance; // Added instance checking
Application.Initialize;
Application.CreateForm(TMainForm, MainForm);
Application.Run;
end.
Documentation for this, and the notification scheme, is at the JCL Wiki.
I use this, works in XE2 through to Alexandria, has the benefit of being able to bring the currently running instance to the front.
Those that say it shouldn't do that, well, given the last thing the user did was to try launch the app, bringing a currently running instance to the front makes sense
unit CheckPrevious;
interface
uses
Windows, SysUtils, WinSock;
function RestoreIfRunning(const AppHandle : THandle; MaxInstances : integer = 1) : boolean;
implementation
type
PInstanceInfo = ^TInstanceInfo;
TInstanceInfo = packed record
PreviousHandle : THandle;
RunCounter : integer;
end;
var
MappingHandle: THandle;
InstanceInfo: PInstanceInfo;
MappingName : string;
RemoveMe : boolean = True;
function RestoreIfRunning(const AppHandle : THandle; MaxInstances : integer = 1) : boolean;
begin
Result := True;
MappingName := StringReplace(ParamStr(0),'\','',[rfReplaceAll, rfIgnoreCase]);
MappingHandle := CreateFileMapping($FFFFFFFF,nil,PAGE_READWRITE,0,SizeOf(TInstanceInfo),PChar(MappingName));
if MappingHandle = 0 then
RaiseLastOSError
else
begin
if GetLastError <> ERROR_ALREADY_EXISTS then
begin
InstanceInfo := MapViewOfFile(MappingHandle,FILE_MAP_ALL_ACCESS,0,0,SizeOf(TInstanceInfo));
InstanceInfo^.PreviousHandle := AppHandle;
InstanceInfo^.RunCounter := 1;
Result := False;
end
else //already runing
begin
MappingHandle := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(MappingName));
if MappingHandle <> 0 then
begin
InstanceInfo := MapViewOfFile(MappingHandle,FILE_MAP_ALL_ACCESS,0,0,SizeOf(TInstanceInfo));
if InstanceInfo^.RunCounter >= MaxInstances then
begin
RemoveMe := False;
if IsIconic(InstanceInfo^.PreviousHandle) then
ShowWindow(InstanceInfo^.PreviousHandle, SW_RESTORE);
SetForegroundWindow(InstanceInfo^.PreviousHandle);
end
else
begin
InstanceInfo^.PreviousHandle := AppHandle;
InstanceInfo^.RunCounter := 1 + InstanceInfo^.RunCounter;
Result := False;
end
end;
end;
end;
end;
initialization
finalization
//remove one instance
if RemoveMe then
begin
MappingHandle := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(MappingName));
if MappingHandle <> 0 then
begin
InstanceInfo := MapViewOfFile(MappingHandle, FILE_MAP_ALL_ACCESS, 0, 0, SizeOf(TInstanceInfo));
InstanceInfo^.RunCounter := -1 + InstanceInfo^.RunCounter;
end
else
RaiseLastOSError;
end;
if Assigned(InstanceInfo) then
UnmapViewOfFile(InstanceInfo);
if MappingHandle <> 0 then
CloseHandle(MappingHandle);
end.
In your project DPR, add the CheckPrevious unit to the uses, then just after begin put the following
if RestoreIfRunning(Application.Handle, 1) then
Exit;
I have no idea of where this code originated, otherwise I would gladly credit the author. (A search of RestoreIfRunning may suggest it was from Zarko Gajic)
This is how i do it.
closeProc(extractfilename(paramstr(0)));
function TForm1.closeProc(pname : string): integer;
const
PROCESS_TERMINATE = $0001;
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
i : integer;
pname2 : string;
begin
try
Result := 0;
i := 0;
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
while Integer(ContinueLoop) <> 0 do
begin
pname2 := trim(UpperCase(ExtractFileName(FProcessEntry32.szExeFile)));
if ( pname2 = uppercase(pname)) then
if FProcessEntry32.th32ProcessID <> GetCurrentProcessId then
begin
Result := Integer(TerminateProcess(OpenProcess(PROCESS_TERMINATE, BOOL(0), FProcessEntry32.th32ProcessID), 0));
inc(i);
end;
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
if i > 50 then
break;
end;
CloseHandle(FSnapshotHandle);
except
end;
end;
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.