Запрет запуска более 1 копии программы

Application.CreateForm(TForm1, Form1);

procedure TForm1.FormCreate(Sender: TObject);
var HM: THandle;
begin
HM := OpenMutex(MUTEX_ALL_ACCESS, false, 'CdpApp');
if (HM <> 0) then
ShowMessage('Уже запушено');
 
if HM = 0 then
  HM := CreateMutex(nil, false, 'CdpApp');
end;

В блоке begin..end модуля .dpr: 
 
 
 
begin
  if HPrevInst <>0 then
  begin
    ActivatePreviousInstance;
    Halt;
  end;
end;

unit PrevInst;
 
interface
 
uses
  WinProcs,
  WinTypes,
  SysUtils;
 
type
  PHWnd = ^HWnd;
 
function EnumApps(Wnd: HWnd; TargetWindow: PHWnd): bool; export;
 
procedure ActivatePreviousInstance;
 
implementation
 
function EnumApps(Wnd: HWnd; TargetWindow: PHWnd): bool;
var
  ClassName: array[0..30] of char;
begin
  Result := true;
  if GetWindowWord(Wnd, GWW_HINSTANCE) = HPrevInst then
  begin
    GetClassName(Wnd, ClassName, 30);
    if STRIComp(ClassName, 'TApplication') = 0 then
    begin
      TargetWindow^ := Wnd;
      Result := false;
    end;
  end;
end;
 
procedure ActivatePreviousInstance;
var
  PrevInstWnd: HWnd;
begin
  PrevInstWnd := 0;
  EnumWindows(@EnumApps, LongInt(@PrevInstWnd));
  if PrevInstWnd <> 0 then
    if IsIconic(PrevInstWnd) then
      ShowWindow(PrevInstWnd, SW_Restore)
    else
      BringWindowToTop(PrevInstWnd);
end;
 
end.

program Previns;
uses
  WinTypes,
  WinProcs,
  SysUtils,
  Forms,
  Uprevins in 'UPREVINS.PAS' {Form1};
{$R *.RES}
 
type
  PHWND = ^HWND;
 
function EnumFunc(Wnd: HWND; TargetWindow: PHWND): bool; export;
var
  ClassName: array[0..30] of char;
begin
  Result := true;
  if GetWindowWord(Wnd, GWW_HINSTANCE) = hPrevInst then
  begin
    GetClassName(Wnd, ClassName, 30);
    if StrIComp(ClassName, 'TApplication') = 0 then
    begin
      TargetWindow^ := Wnd;
      Result := false;
    end;
  end;
end;
 
procedure GotoPreviousInstance;
var
  PrevInstWnd: HWND;
begin
  PrevInstWnd := 0;
  EnumWindows(@EnumFunc, Longint(@PrevInstWnd));
  if PrevInstWnd <> 0 then
    if IsIconic(PrevInstWnd) then
      ShowWindow(PrevInstWnd, SW_RESTORE)
    else
      BringWindowToTop(PrevInstWnd);
end;
 
begin
  if hPrevInst <> 0 then
    GotoPreviousInstance
  else
  begin
    Application.CreateForm(TForm1, Form1);
    Application.Run;
  end;
end.

...
uses syncobjs;
...
var
  CheckEvent: TEvent;
 
...
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  CheckEvent := TEvent.Create(nil, false, true, 'MYPROGRAM_CHECKEXIST');
  if CheckEvent.WaitFor(10) <> wrSignaled then
  begin
    // Сюда попадаем если одна копия уже запущена.
    // Можно, например, сообщить об этом пользователю.
    Self.Close; // Здесь можно завершить программу или сделать еще что-нибудь.
  end;
end;

program Project1;
 
uses
  Forms,
  Windows,
  Unit1 in 'Unit1.pas' {Form1};
 
{$R *.RES}
 
var
  hwnd: THandle;
 
begin
  hwnd := FindWindow('TForm1', 'Form1');
  if hwnd = 0 then
  begin
    Application.Initialize;
    Application.CreateForm(TForm1, Form1);
    Application.Run;
  end
  else
    SetForegroundWindow(hwnd)
end.

program pds;
 
uses
  Windows,
  Forms,
  Main in 'MAIN.PAS' {MainForm},
 
const
  MemFileSize = 127;
  MemFileName = 'one_example';
 
var
  MemHnd: HWND;
 
{$R *.RES}
 
begin
 
  MemHnd := CreateFileMapping(HWND($FFFFFFFF), nil,
    PAGE_READWRITE, 0, MemFileSize,
    MemFileName);
  if GetLastError <> ERROR_ALREADY_EXISTS then
  begin
    Application.Initialize;
    with TForm1.Create(nil) do
    try
      Show;
      Update;
      Application.CreateForm(TMainForm, MainForm);
    finally
      Free;
    end;
    Application.Run;
  end
  else
    Application.MessageBox('Приложение уже запущено (возможно оно свернуто
      на панели задач): Нажмите кнопку ОК для продолжения работы',
      'Производственно-диспетчерская служба', MB_OK);
  CloseHandle(MemHnd);
end.

ActivatePrevInstance('TForm1','Значение Caption ');

program Project1;
 
uses
  previnst, windows, Forms,
  Unit1 in 'Unit1.pas' {Form1};
 
{$R *.RES}
begin
  if mmm then
  begin
    ShowWindow(FindWindow('tform1', 'Имя окна которое активизировать'),
      SW_restore);
 
    SetForegroundWindow(FindWindow('tform1', 'Имя окна которое
      активизировать'));
 
      halt; //завершить программу не создавая ничего.
  end;
 
  //Тело программы прогры
 
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

unit Previnst;
 
interface
 
uses Windows;
 
var
  mmm: boolean; //эта переменная если true то программа уже запущена
 
implementation
 
var
  hMutex: integer;
begin
  mmm := false;
  hMutex := CreateMutex(nil, TRUE, 'AbraShvabra'); // Создаем семафор
  if GetLastError <> 0 then
    mmm := true; // Ошибка семафор уже создан
  ReleaseMutex(hMutex);
end.

unit multinst;
{
 
Применение:
Необходимый код в исходном проекте
 
if InitInstance then
begin
Application.Initialize;
Application.CreateForm(TFrmSelProject, FrmSelProject);
Application.Run;
end;
Это все понятно (я надеюсь)
}
 
interface
 
uses Forms, Windows, Dialogs, SysUtils;
 
const
 
  MI_NO_ERROR = 0;
  MI_FAIL_SUBCLASS = 1;
  MI_FAIL_CREATE_MUTEX = 2;
 
  { Проверка правильности запуска приложения с помощью описанных ниже функций. }
  { Количество флагов ошибок MI_* может быть более одного. }
 
function GetMIError: Integer;
function InitInstance: Boolean;
 
implementation
 
const
 
  UniqueAppStr: PChar; {Различное для каждого приложения}
 
var
 
  MessageId: Integer;
  WProc: TFNWndProc = nil;
  MutHandle: THandle = 0;
  MIError: Integer = 0;
 
function GetMIError: Integer;
begin
 
  Result := MIError;
end;
 
function NewWndProc(Handle: HWND; Msg: Integer; wParam,
 
  lParam: Longint): Longint; stdcall;
begin
 
  { Если это - сообщение о регистрации... }
 
  if Msg = MessageID then
  begin
    { если основная форма минимизирована, восстанавливаем ее }
 
{ передаем фокус приложению }
    if IsIconic(Application.Handle) then
    begin
      Application.MainForm.WindowState := wsNormal;
      ShowWindow(Application.Mainform.Handle, sw_restore);
    end;
    SetForegroundWindow(Application.MainForm.Handle);
  end
    { В противном случае посылаем сообщение предыдущему окну }
  else
    Result := CallWindowProc(WProc, Handle, Msg, wParam, lParam);
end;
 
procedure SubClassApplication;
begin
 
  { Обязательная процедура. Необходима, чтобы обработчик }
  { Application.OnMessage был доступен для использования. }
  WProc := TFNWndProc(SetWindowLong(Application.Handle, GWL_WNDPROC,
    Longint(@NewWndProc)));
  { Если происходит ошибка, устанавливаем подходящий флаг }
  if WProc = nil then
    MIError := MIError or MI_FAIL_SUBCLASS;
end;
 
procedure DoFirstInstance;
begin
 
  SubClassApplication;
  MutHandle := CreateMutex(nil, False, UniqueAppStr);
  if MutHandle = 0 then
    MIError := MIError or MI_FAIL_CREATE_MUTEX;
end;
 
procedure BroadcastFocusMessage;
{ Процедура вызывается, если уже имеется запущенная копия Вашей программы. }
var
 
  BSMRecipients: DWORD;
begin
  { Не показываем основную форму }
 
  Application.ShowMainForm := False;
  { Посылаем другому приложению сообщение и информируем о необходимости }
  { перевести фокус на себя }
  BSMRecipients := BSM_APPLICATIONS;
  BroadCastSystemMessage(BSF_IGNORECURRENTTASK or BSF_POSTMESSAGE,
    @BSMRecipients, MessageID, 0, 0);
end;
 
function InitInstance: Boolean;
begin
 
  MutHandle := OpenMutex(MUTEX_ALL_ACCESS, False, UniqueAppStr);
  if MutHandle = 0 then
  begin
    { Объект Mutex еще не создан, означая, что еще не создано }
 
{ другое приложение. }
    ShowWindow(Application.Handle, SW_ShowNormal);
    Application.ShowMainForm := True;
    DoFirstInstance;
    result := True;
  end
  else
  begin
    BroadcastFocusMessage;
    result := False;
  end;
end;
 
initialization
  begin
 
    UniqueAppStr := Application.Exexname;
    MessageID := RegisterWindowMessage(UniqueAppStr);
    ShowWindow(Application.Handle, SW_Hide);
    Application.ShowMainForm := FALSE;
  end;
 
finalization
  begin
 
    if WProc <> nil then
      { Приводим приложение в исходное состояние }
 
      SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(WProc));
  end;
end.

var
  MutexHandle: THandle;
var
  UniqueKey: string;
 
function IsNextInstance: BOOLEAN;
begin
 
  Result := FALSE;
 
  MutexHandle := 0;
  MutexHandle := CREATEMUTEX(nil, TRUE, UniqueKey);
  if MutexHandle <> 0 then
  begin
    if GetLastError = ERROR_ALREADY_EXISTS then
    begin
      Result := TRUE;
      CLOSEHANDLE(MutexHandle);
      MutexHandle := 0;
    end;
  end;
end;
 
begin
 
  CmdShow := SW_HIDE;
  MessageId := RegisterWindowMessage(zAppName);
  Application.Initialize;
  if IsNextInstance then
    PostMessage(HWND_BROADCAST, MessageId, 0, 0)
  else
  begin
    Application.ShowMainForm := FALSE;
    Application.CreateForm(TMainForm, MainForm);
    MainForm.StartTimer.Enabled := TRUE;
    Application.Run;
  end;
  if MutexHandle <> 0 then
    CLOSEHANDLE(MutexHandle);
end.

procedure TMainForm.OnAppMessage(var M: TMSG; var Ret: BOOLEAN);
begin
  if M.Message = MessageId then
  begin
    Ret := TRUE;
    // Поместить окно наверх !!!!!!!!
  end;
end;
 
initialization
  ShowWindow(Application.Handle, SW_Hide);
end.

unit MultInst;
 
interface
 
const
  MI_QUERYWINDOWHANDLE = 1;
  MI_RESPONDWINDOWHANDLE = 2;
 
  MI_ERROR_NONE = 0;
  MI_ERROR_FAILSUBCLASS = 1;
  MI_ERROR_CREATINGMUTEX = 2;
 
  // Call this function to determine if error occurred in startup.
  // Value will be one or more of the MI_ERROR_* error flags.
function GetMIError: Integer;
 
implementation
 
uses Forms, Windows, SysUtils;
 
const
  UniqueAppStr = 'DDG.I_am_the_Eggman!';
 
var
  MessageId: Integer;
  WProc: TFNWndProc;
  MutHandle: THandle;
  MIError: Integer;
 
function GetMIError: Integer;
begin
  Result := MIError;
end;
 
function NewWndProc(Handle: HWND; Msg: Integer; wParam, lParam: Longint):
  Longint; stdcall;
begin
  Result := 0;
  // If this is the registered message...
  if Msg = MessageID then
  begin
    case wParam of
      MI_QUERYWINDOWHANDLE:
        // A new instance is asking for main window handle in order
        // to focus the main window, so normalize app and send back
        // message with main window handle.
        begin
          if IsIconic(Application.Handle) then
          begin
            Application.MainForm.WindowState := wsNormal;
            Application.Restore;
          end;
          PostMessage(HWND(lParam), MessageID, MI_RESPONDWINDOWHANDLE,
            Application.MainForm.Handle);
        end;
      MI_RESPONDWINDOWHANDLE:
        // The running instance has returned its main window handle,
        // so we need to focus it and go away.
        begin
          SetForegroundWindow(HWND(lParam));
          Application.Terminate;
        end;
    end;
  end
    // Otherwise, pass message on to old window proc
  else
    Result := CallWindowProc(WProc, Handle, Msg, wParam, lParam);
end;
 
procedure SubClassApplication;
begin
  // We subclass Application window procedure so that
  // Application.OnMessage remains available for user.
  WProc := TFNWndProc(SetWindowLong(Application.Handle, GWL_WNDPROC,
    Longint(@NewWndProc)));
  // Set appropriate error flag if error condition occurred
  if WProc = nil then
    MIError := MIError or MI_ERROR_FAILSUBCLASS;
end;
 
procedure DoFirstInstance;
// This is called only for the first instance of the application
begin
  // Create the mutex with the (hopefully) unique string
  MutHandle := CreateMutex(nil, False, UniqueAppStr);
  if MutHandle = 0 then
    MIError := MIError or MI_ERROR_CREATINGMUTEX;
end;
 
procedure BroadcastFocusMessage;
// This is called when there is already an instance running.
var
  BSMRecipients: DWORD;
begin
  // Prevent main form from flashing
  Application.ShowMainForm := False;
  // Post message to try to establish a dialogue with previous instance
  BSMRecipients := BSM_APPLICATIONS;
  BroadCastSystemMessage(BSF_IGNORECURRENTTASK or BSF_POSTMESSAGE,
    @BSMRecipients, MessageID, MI_QUERYWINDOWHANDLE,
    Application.Handle);
end;
 
procedure InitInstance;
begin
  SubClassApplication; // hook application message loop
  MutHandle := OpenMutex(MUTEX_ALL_ACCESS, False, UniqueAppStr);
  if MutHandle = 0 then
    // Mutex object has not yet been created, meaning that no previous
    // instance has been created.
    DoFirstInstance
  else
    BroadcastFocusMessage;
end;
 
initialization
  MessageID := RegisterWindowMessage(UniqueAppStr);
  InitInstance;
finalization
  // Restore old application window procedure
  if WProc <> nil then
    SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(WProc));
  if MutHandle <> 0 then
    CloseHandle(MutHandle); // Free mutex
end.
unit OIMain;
 
interface
 
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;
 
type
  TMainForm = class(TForm)
    Label1: TLabel;
    CloseBtn: TButton;
    procedure CloseBtnClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
var
  MainForm: TMainForm;
 
implementation
 
uses MultInst;
 
{$R *.DFM}
 
procedure TMainForm.CloseBtnClick(Sender: TObject);
begin
  Close;
end;
 
end.

program Project1;
 
uses
  windows,
  Forms,
  Unit1 in 'Unit1.pas' {Form1};
 
var HM: THandle;
{$R *.res}
 
begin
  HM := OpenMutex(MUTEX_ALL_ACCESS, false, 'CdpApp');
  if (HM <> 0) then
    begin
      exit;
    end
  else
    HM := CreateMutex(nil, false, 'CdpApp');
  Application.Initialize;
  Application.MainFormOnTaskbar := True;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

procedure CanStart;
var
  Mtx: THandle;
begin
  Mtx := CreateMutex(nil, False, 'application_duplicate');
  if WaitForSingleObject(Mtx, 0) <> WAIT_OBJECT_0 then
    Application.Terminate;
end;

CreateFileMapping(HWND($FFFFFFFF), nil, PAGE_READWRITE, 0, 1024, 
'Programm Name'); 
if GetLastError <> ERROR_ALREADY_EXISTS then 
begin 
Application.Initialize; 
Application.CreateForm(TForm1, Form1); 
Application.Run; 
end 
else 
begin 
Application.MessageBox('Программа уже запущена !', 'Внимание'); 
halt; 
end;

program Project2;
 
uses
Windows,
  Vcl.Forms,
  Unit1 in 'Unit1.pas' {Form1};
 
{$R *.res}
 
begin
CreateFileMapping(HWND($FFFFFFFF), nil, PAGE_READWRITE, 0, 1024,
'Programm Name');
if GetLastError <> ERROR_ALREADY_EXISTS then
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end
else
begin
Application.MessageBox('Программа уже выполняется!', 'Внимание');
halt;
end;
end.

 Var
....
 RunAtom   : Integer = 0;
....
procedure TForm1.FormCreate(Sender: TObject);
begin
  RunAtom:=GlobalFindAtom('FiFiFi'); //Здесь какое-нибудь уникальное имя придумать
  If RunAtom<>0 then
    Begin
      MessageBeep(MB_ICONASTERISK);  //
      Sleep(600);
      Application.MessageBox('Программа FiFiFi уже выполняется!','FiFiFi',MB_OK);
      Halt;
    end;
  RunAtom:=GlobalAddAtom('FiFiFi');
...
end;
...
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
...
   If RunAtom<>0 then GlobalDeleteAtom(RunAtom);
...
end;
end.

program Project2;
 
uses
Windows,
  Vcl.Forms,
  Unit1 in 'Unit1.pas' {Form1};
 
{$R *.res}
 
const
  MUTEX = 'dfdsfdsf_Mutex_bv387w';
 var
  hMutex: THandle;
begin
 
 
  hMutex := OpenMutex(MUTEX_ALL_ACCESS, False, MUTEX);
  if hMutex <> 0 then
  begin
    MessageBox(0,'Error!','Error!',0);
    Exit;
  end;
  hMutex := CreateMutex(nil, False, MUTEX);
  Application.Initialize;
  Application.MainFormOnTaskbar := True;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
  if hMutex <> 0 then
  begin
    ReleaseMutex(hMutex);
    CloseHandle(hMutex);
  end;
 
end.