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.