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.