如何使用 Delphi 检查进程是否正在运行?

hzbexzde  于 2024-01-07  发布在  其他
关注(0)|答案(5)|浏览(308)

类似于这个问题,但在 Delphi :
How do I find out if a process is already running using c#?
我有一个更新程序,我想让它检查程序的更新是不是目前正在运行,最好是它会检查所有用户,而不仅仅是当前用户。

ru9i0ody

ru9i0ody1#

来源:http://www.delphitricks.com/source-code/windows/check_if_a_process_is_running.html

  1. uses TlHelp32;
  2. function processExists(exeFileName: string): Boolean;
  3. var
  4. ContinueLoop: BOOL;
  5. FSnapshotHandle: THandle;
  6. FProcessEntry32: TProcessEntry32;
  7. begin
  8. FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  9. FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
  10. ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
  11. Result := False;
  12. while Integer(ContinueLoop) <> 0 do
  13. begin
  14. if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
  15. UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =
  16. UpperCase(ExeFileName))) then
  17. begin
  18. Result := True;
  19. end;
  20. ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
  21. end;
  22. CloseHandle(FSnapshotHandle);
  23. end;
  24. procedure TForm1.Button1Click(Sender: TObject);
  25. begin
  26. if processExists('notepad.exe') then
  27. ShowMessage('process is running')
  28. else
  29. ShowMessage('process not running');
  30. end;

字符串

展开查看全部
ni65a41a

ni65a41a2#

如果您正在编写一些自动更新代码,您还可以考虑与应用程序建立某种连接,并告诉它自行关闭。
例如,这可能涉及到在应用程序的主窗口发布一条消息,告诉它关闭自己。或者打开一个IPC管道等。

dm7nw8vv

dm7nw8vv3#

  1. uses TlHelp32, PsAPI;
  2. function ProcessExists(anExeFileName: string): Boolean;
  3. var
  4. ContinueLoop: BOOL;
  5. FSnapshotHandle: THandle;
  6. FProcessEntry32: TProcessEntry32;
  7. fullPath: string;
  8. myHandle: THandle;
  9. myPID: DWORD;
  10. begin
  11. // wsyma 2016-04-20 Erkennung, ob ein Prozess in einem bestimmten Pfad schon gestartet wurde.
  12. // Detection wether a process in a certain path is allready started.
  13. // http://stackoverflow.com/questions/876224/how-to-check-if-a-process-is-running-using-delphi
  14. // http://swissdelphicenter.ch/en/showcode.php?id=2010
  15. FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  16. FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
  17. ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
  18. Result := False;
  19. while Integer(ContinueLoop) <> 0 do
  20. begin
  21. if UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) = UpperCase(ExtractFileName(anExeFileName)) then
  22. begin
  23. myPID := FProcessEntry32.th32ProcessID;
  24. myHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, myPID);
  25. if myHandle <> 0 then
  26. try
  27. SetLength(fullPath, MAX_PATH);
  28. if GetModuleFileNameEx(myHandle, 0, PChar(fullPath), MAX_PATH) > 0 then
  29. begin
  30. SetLength(fullPath, StrLen(PChar(fullPath)));
  31. if UpperCase(fullPath) = UpperCase(anExeFileName) then
  32. Result := True;
  33. end else
  34. fullPath := '';
  35. finally
  36. CloseHandle(myHandle);
  37. end;
  38. if Result then
  39. Break;
  40. end;
  41. ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
  42. end;
  43. CloseHandle(FSnapshotHandle);
  44. end;

字符串

展开查看全部
mf98qq94

mf98qq944#

如果你可以控制应用程序(正如你的问题所暗示的那样),一个很好的方法是在进程开始的早期创建一个命名的文件Map对象。这类似于从RedLEON创建一个互斥体的建议。

  1. // Add this into the application you wish to update
  2. CreateFileMapping(HWND($FFFFFFFF), nil, PAGE_READONLY, 0, 32, 'MAIN-PROGRAM');
  3. // Note: Mapping object is destroyed when your application exits
  4. // Add this into your updater application
  5. var
  6. hMapping: HWND;
  7. begin
  8. hMapping := CreateFileMapping(HWND($FFFFFFFF), nil, PAGE_READONLY, 0, 32, 'MAIN-PROGRAM');
  9. if (hMapping <> 0) then
  10. begin
  11. if (GetLastError() = ERROR_ALREADY_EXISTS) then
  12. ShowMessage('Application to update is already running!');
  13. end;

字符串
查看MSDN documentation on CreateFileMapping以了解更多详细信息。
另请参阅this question的公认答案,其中涵盖了路加的答案并提供了其他解决方案。

展开查看全部
5ssjco0h

5ssjco0h5#

我正在输入这些代码初始化主机的一部分。

  1. initialization
  2. mHandle := CreateMutex(nil, True, 'myApp.ts');
  3. if GetLastError = ERROR_ALREADY_EXISTS then
  4. begin
  5. MessageDlg('Program already running!', mtError, [mbOK], 0);
  6. Halt;
  7. end;

字符串

相关问题