【Delphi】运行程序时自动检查程序是否已经有一个实例在运行

//uCheckAppRunning.pas： 

unit uCheckAppRunning; //检查程序是否已经在运行，不允许运行多个实例

interface

uses
  System.SysUtils, System.Classes, Winapi.Windows, Vcl.Forms, Winapi.Messages,
  Vcl.ExtCtrls, Vcl.Menus, Vcl.Dialogs, Winapi.TlHelp32, Winapi.PsAPI;

type
  TShowApp = class(TDataModule)
    procedure DataModuleCreate(Sender: TObject);
    procedure DataModuleDestroy(Sender: TObject);
  private
    Handle: THandle;
    MainForm: TForm;
    WM_SHOW_MAINFORM: DWORD;
    WindowState: TWindowState;
    procedure WndProc(var Msg: TMessage);
    function  ForceForegroundWindow(hWnd: THandle): Boolean;
  private
    class function GetPIDByProgramName(const APName: string; ExcludedPID: THandle = 0): THandle;
    class function QueryFullProcessImageName
      (hProcess: THandle; dwFlags: DWORD; lpExeName: PChar; nSize: PDWORD ): BOOL;
  public
    class function IsAppRunning: Boolean;
  end;

var
  ShowApp: TShowApp;

implementation    //检查程序是否已经运行(对比文件路径和文件名是否相同)

{$R *.dfm}

{使用方法：
  1.将此单元(uCheckAppRunning)加入到项目中(procject->Add to project...)
  2.打开菜单Project->ViewSource, 在Initialize语句前加入一行：
    if TShowApp.IsAppRunning then Exit;
}

procedure TShowApp.DataModuleCreate(Sender: TObject);
begin
  MainForm := Application.MainForm;
  Handle := AllocateHWnd(WndProc);
  WindowState := MainForm.WindowState;
  WM_SHOW_MAINFORM := RegisterWindowMessage(PChar(Application.ExeName));
end;

procedure TShowApp.DataModuleDestroy(Sender: TObject);
begin
  DeallocateHWnd(Handle);
end;

procedure TShowApp.WndProc(var Msg: TMessage);
begin
  with Msg do
  begin
    if (Msg = WM_SHOW_MAINFORM) then
    begin
      if (WParam <> DWORD(Application)) then
      begin
        MainForm.Show;
        if MainForm.WindowState = wsMinimized then
        begin
          MainForm.WindowState := WindowState;
        end;
        ForceForegroundWindow(MainForm.Handle);
      end;
    end
    else
    begin
      DefWindowProc(Handle, Msg, wParam, lParam);
    end;
  end;
end;

class function TShowApp.IsAppRunning: Boolean;
var
  WM_SHOW_MAINFORM: DWORD;
  AHandle, ExcludedPID: THandle;
begin
  Result := False;
  if System.ParamCount = 0 then
    AHandle := GetPIDByProgramName(Application.ExeName)
  else
  begin
    ExcludedPID := THandle(StrToInt(System.ParamStr(1)));
    AHandle := GetPIDByProgramName(Application.ExeName, ExcludedPID);
  end;
  if AHandle <> 0 then
  begin
    if Application.MessageBox('本程序已经有一个实例在运行，不允许再运行另一个实例。是否查看正在运行的实例？',
                '警告：程序无法运行，即将退出', MB_YESNO) = IDYes then
    begin
      WM_SHOW_MAINFORM := RegisterWindowMessage(PChar(Application.ExeName));
      PostMessage(HWND_BROADCAST, WM_SHOW_MAINFORM, DWORD(Application), 0);
    end;
    Result := True;
  end;
end;

class function TShowApp.GetPIDByProgramName(const APName: string; ExcludedPID: THandle = 0): THandle;
var
  Len: Cardinal;
  IsFound: Boolean;
  HModule, HProcess, CurrentProcessId: THandle;
  ProcessEntry32: TProcessEntry32;
  szPath: array[0..MAX_PATH] of Char;
begin
  Result := 0;
  CurrentProcessId := GetCurrentProcessId;
  HModule := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  try
    ProcessEntry32.dwSize := Sizeof(ProcessEntry32);
    IsFound := Process32First(HModule, ProcessEntry32);
    while IsFound do
    begin
      FillChar(szPath, MAX_PATH + 1, #0);
      HProcess := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ,
                                       False, ProcessEntry32.th32ProcessID);
      if Win32MajorVersion < 6  then    //WinVista的版本号是6.0
        //WinXP或更旧版本
        GetModuleFileNameEx(HProcess, 0, szPath, sizeof(szPath))
      else
      begin
        Len := MAX_PATH + 1; //WinVista或更新版本
        if QueryFullProcessImageName(HProcess, 0, szPath, @Len) then
      end;
      CloseHandle(HProcess);
      if ((UpperCase(StrPas(szPath)) = UpperCase(APName)) or
          (UpperCase(StrPas(ProcessEntry32.szExeFile)) = UpperCase(APName))) and
         (ProcessEntry32.th32ProcessID <> CurrentProcessId) then
      begin
        if (ProcessEntry32.th32ProcessID <> ExcludedPID) then
        begin //解决自动重启时新实例已启动但旧实例还没完全退出的问题
          Result := ProcessEntry32.th32ProcessID;
          break;
        end
      end;
      IsFound := Process32Next(HModule, ProcessEntry32);
    end;
    finally
    CloseHandle(HModule);
  end;
end;

//function GetProcessImageFileName(hProcess:THandle; lpImageFileName:LPTSTR;
//nSize:DWORD):DWORD; stdcall; external 'PSAPI.dll' name 'GetProcessImageFileNameW';
//--在WinXP中没有GetProcessImageFileName---
class function TShowApp.QueryFullProcessImageName(hProcess: THandle; dwFlags: DWORD;
              lpExeName: PChar; nSize: PDWORD ): BOOL;
var
  HKernel32: HModule;
  _QueryFullProcessImageName: function(hProcess: THandle; dwFlags: DWORD;
                              lpExeName: PChar; nSize: PDWORD ): BOOL; stdcall;
begin
  // Kernel32 is always loaded already, so use GetModuleHandle
  // instead of LoadLibrary
  HKernel32 := GetModuleHandle('kernel32');
  if HKernel32 = 0 then
    RaiseLastOSError;
  @_QueryFullProcessImageName := GetProcAddress(HKernel32, 'QueryFullProcessImageNameW');
  if not Assigned(_QueryFullProcessImageName) then
    RaiseLastOSError;
  Result := _QueryFullProcessImageName(hProcess, dwFlags, lpExeName, nSize);
end;

function TShowApp.ForceForegroundWindow(hWnd: THandle): Boolean;
const
  SPI_GETFOREGROUNDLOCKTIMEOUT = $2000;
  SPI_SETFOREGROUNDLOCKTIMEOUT = $2001;
var
  ForegroundThreadID: DWORD;
  ThisThreadID: DWORD;
  timeout: DWORD;
begin
  if GetForegroundWindow = hWnd then
    Result := True
  else
  begin
    Result := False;
    ForegroundThreadID := GetWindowThreadProcessID(GetForegroundWindow, nil);
    ThisThreadID := GetWindowThreadPRocessId(hWnd, nil);
    if AttachThreadInput(ThisThreadID, ForegroundThreadID, True) then
    begin
      BringWindowToTop(hWnd);
      SetForegroundWindow(hWnd);
      AttachThreadInput(ThisThreadID, ForegroundThreadID, False);
      Result := (GetForegroundWindow = hWnd);
    end;
    if not Result then
    begin
      SystemParametersInfo(SPI_GETFOREGROUNDLOCKTIMEOUT, 0, @timeout, 0);
      SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(0),
        SPIF_SENDCHANGE);
      BringWindowToTop(hWnd);
      SetForegroundWindow(hWnd);
      SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(timeout), SPIF_SENDCHANGE);
    end;
    Result := (GetForegroundWindow = hWnd);
  end;
end;

end.

 

//uCheckAppRunning.dfm： 

object ShowApp: TShowApp
  OldCreateOrder = False
  OnCreate = DataModuleCreate
  OnDestroy = DataModuleDestroy
  Height = 371
  Width = 636
end