//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