Impedir ejecucion simultanea

[jconnor82]

De mucha utilidad la unidad, la uso desde hace tiempo , aunque realice unos cambios a la unidad para convertirla en funcion:

Código Delphi [-]
unit MclApplication;

interface

uses
  Windows, SysUtils, Forms;

// GENERALES -------------------------------------------------------------------

procedure ApplicationActive(Handle: HWND); overload;

procedure ApplicationActive; overload;

// One Instance ----------------------------------------------------------------

function InstanceExists(Identifier: string): Boolean;

implementation

// GENERALES -------------------------------------------------------------------

procedure ApplicationActive(Handle: HWND); overload;
var
  FgThreadId  : DWORD;
  AppThreadId : DWORD;
begin
  if IsIconic(Handle) then
    ShowWindow(Handle, SW_RESTORE)
  else
  begin
    { Obtener los hilos }
    FgThreadId  := GetWindowThreadProcessId(GetForegroundWindow, nil);
    AppThreadId := GetWindowThreadProcessId(Handle, nil);
    { Anexar el hilo de nuestra app. al de la  que tenga el foco }
    AttachThreadInput(AppThreadId, FgThreadId, true);
    { Ahora sí, InstanceActivar la applicación }
    SetForegroundWindow(Handle);
    { Separar el hilo de nuestra app de la otra }
    AttachThreadInput(AppThreadId, FgThreadId, false);
  end;
end;

procedure ApplicationActive;
begin
  ApplicationActive(Application.Handle);
end;

//------------------------------------------------------------------------------
// One Instance
//------------------------------------------------------------------------------

var
  mActivar    : Cardinal; { Mensaje para activar la instancia anterior }
  Mutex       : Cardinal; { Mutex }
  PrevWndProc : TFarProc; { Procedimiento de ventana original }

function AppWndProc(Handle: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LongInt; stdcall;
begin
  if Msg = mActivar then
  begin
    ApplicationActive(Handle);
    Result := 0;
  end else
    { Dejar que el procedimiento original se encargue de los otros mensajes }
    Result := CallWindowProc(PrevWndProc, Handle, Msg, wParam, lParam);
end;

procedure InstanceActivar;
begin
  { Mandamos el mensaje a todas las ventanas }
  SendMessage(HWND_BROADCAST, mActivar, 0, 0);
end;

procedure InstanceRegistrar(Identifier: string);
const
  { Cadenas para InstanceRegistrar el mutex y el mensaje }
  sMutex   = '10D73234-C9F7-4C2D-BC7E-39B5820AF456';
  sActivar = '3F154732-CCDE-4BC7-9439-AFCD3BCFA84D';
begin
  mActivar := RegisterWindowMessage(PChar(sActivar + Identifier));
  Mutex    := CreateMutex(nil, true, PChar(sMutex + Identifier));
  { Si ya existe el mutex lanzamos una excepción silenciosa }
  if GetLastError = ERROR_ALREADY_EXISTS then
  begin
    Mutex := 0;
    Abort;
  end else
  begin
    { Sustituimos el procedimiento de ventana }
    PrevWndProc := TFarProc(GetWindowLong(Application.Handle, GWL_WNDPROC));
    SetWindowLong(Application.Handle, GWL_WNDPROC, LongWord(@AppWndProc));
  end;
end;

function InstanceExists(Identifier: string): Boolean;
begin
  Result := True;
  try
    InstanceRegistrar(Identifier);
    Result := False;
  except
    InstanceActivar;
//    Halt; //Termina la aplicacion
  end;
end;

initialization

finalization

  if Mutex <> 0 then ReleaseMutex(Mutex);

end.

un ejemplo de uso, en el dpr:

Código Delphi [-]
 program Project1;
 
 uses
   Forms,
   Unit1 in 'Unit1.pas' {Form1};
 
 {$R *.res}
 
 begin
   if InstanceExists('MI APLICACION') then
     Exit;
 
   Application.Initialize;
   Application.MainFormOnTaskbar := True;
   Application.CreateForm(TForm1, Form1);
   Application.Run;
 end.