unit loMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    FMutex: array [0..1] of THandle;
    FEvent: THandle;
    FThread: TThread;
  public
    procedure WaitSingleInstance;
    procedure DoSingleInstance;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.DoSingleInstance;
begin
  ShowMessage('Single Instance!');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FEvent := CreateEvent(nil, True, False, nil);
  FMutex[0] := CreateMutex(nil, False, 'TLO_A');
  FMutex[1] := CreateMutex(nil, False, 'TLO_B');
  WaitSingleInstance;
end;

procedure TForm1.FormDestroy(Sender: TObject);
var
  ThreadHandle: Thandle;
begin
  ThreadHandle := FThread.Handle;
  SetEvent(FEvent); //Killing thread
  WaitForSingleObject(ThreadHandle, INFINITE);
  CloseHandle(FEvent);
  { !!! Не закрываем хэндлы мьютексов! }
end;

procedure TForm1.WaitSingleInstance;
begin
  FThread := TThread.CreateAnonymousThread(

    procedure
    var
      IsSingleInstance: Boolean;
      hObjects: array of THandle;
    begin
      IsSingleInstance := True;
      hObjects := [FMutex[0], FMutex[1], FEvent];

      { Ждём получения первого мьютекса }
      case WaitForMultipleObjects(3, @hObjects[0], False, INFINITE) of

        WAIT_OBJECT_0,
        WAIT_ABANDONED_0:
          hObjects := [FMutex[1], FEvent];

        WAIT_OBJECT_0 + 1,
        WAIT_ABANDONED_0 + 1:
          hObjects := [FMutex[0], FEvent];

      else
        Exit;
      end;

      while WaitForSingleObject(FEvent, 0) = WAIT_TIMEOUT do
      begin

        { Ждём получения второго мьютекса }
        case WaitForMultipleObjects(2, @hObjects[0], False, 100) of

          WAIT_OBJECT_0,
          WAIT_ABANDONED_0:
            begin
              ReleaseMutex(hObjects[0]);
              if IsSingleInstance then
              begin
                Sleep(100);
                Continue;
              end;
            end;

          WAIT_TIMEOUT:
            begin
              IsSingleInstance := False;
              Continue;
            end

        else
          Exit;
        end;

        { Проверяем - перехватил ли кто-нибудь мьютекс? }
        if WaitForSingleObject(hObjects[0], 0) = WAIT_OBJECT_0 then
        begin
          IsSingleInstance := True;
          ReleaseMutex(hObjects[0]);
          TThread.Synchronize(nil, DoSingleInstance);
        end;

      end;
    end);

  FThread.Start;
end;

end.

library instcounter;

uses
  WinAPI.Windows;

{$R *.res}

const
  S_EVENT = 'SI_CHECK';
  S_MEMORY = 'SI_COUNTER';

var
  InstanceCount: PInteger = nil;
  hSignalEvent: THandle = 0;
  hMapFile: THandle = 0;

procedure DllMain(Reason: Integer);
var
  Count: Integer;
begin
  if Reason = DLL_PROCESS_ATTACH then
  begin
    hMapFile := CreateFileMapping(INVALID_HANDLE_VALUE, nil, PAGE_READWRITE, 0, SizeOf(Integer), S_MEMORY);
    if hMapFile <> 0 then
      InstanceCount := MapViewOfFile(hMapFile, FILE_MAP_ALL_ACCESS, 0, 0, SizeOf(Integer));
    if InstanceCount <> nil then
      InterlockedIncrement(InstanceCount^);
  end else if Reason = DLL_PROCESS_DETACH then
  begin
    if InstanceCount <> nil then
    begin
      Count := InterlockedDecrement(InstanceCount^);
      UnmapViewOfFile(InstanceCount);
      if Count = 1 then
        SetEvent(hSignalEvent);
    end;
    CloseHandle(hMapFile);
  end;
end;

begin
  DllProc := DllMain;
  if hSignalEvent = 0 then
    hSignalEvent := CreateEvent(nil, False, False, S_EVENT);
  DllMain(DLL_PROCESS_ATTACH);
end.

unit siMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    FEvent: THandle;
    procedure AppIdle(Sender: TObject; var Done: Boolean);
    procedure DoSingleInstance;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.AppIdle(Sender: TObject; var Done: Boolean);
begin
  if WaitForSingleObject(FEvent, 0) = WAIT_OBJECT_0 then
    DoSingleInstance;
end;

procedure TForm1.DoSingleInstance;
begin
  ShowMessage('Single Instance!');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FEvent := CreateEvent(nil, False, False, 'SI_CHECK');
  if LoadLibrary(Pointer(ExtractFilePath(Application.ExeName) + 'instcounter.dll')) = 0 then
    RaiseLastOSError;
  Application.OnIdle := AppIdle;
end;

end.