Impedir ejecucion simultanea

[mefixxto]

Como puedo impedir al usuario que no pueda abrir 2 veces el mismo programa...
Que aparezca una ventanita informativa que me diga "el programa ya esta corriendo"..

gracias

[Neftali [Germán.Estévez]]

Con una simple búsqueda en los foros, seguro que hubieras obtenido entre otros resultados, varios que te hubieran llevado a la página de Román. Donde está el código necesario, además de una completa explicación, para conseguir lo que necesitas.

[Loviedo]

Con la Unidad UIApp me funciona muy bien, pero al añadir la mejora de Seoane
- Sustitución de lineas en Procedure Registro - la aplicación vuelve a ejecutarse múltiples veces con lo que tengo que sustituir las cadenas en cada proyecto.
¿Hay que hacer algo más?
Saludos y gracias

[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.

[Loviedo]

La función también va bien pero me veo obligado a cambiar el GUID siempre que haya más de una aplicación en el mismo PC, que es lo que pretende la mejora de SEOANE (no tener que cambiarlo) según he entendido.
Tengo dos aplicaciones en el mismo PC y efectivamente solo se ejecuta una sola instancia, pero si el GUID es el mismo, solo puedo ejecutar una de las dos.Simultaneamente no se puede.
Saludos.

[Loviedo]

Perdón. Funciona estupendamente.
Saludos.

[roman]

Empezado por Loviedo

al añadir la mejora de Seoane
- Sustitución de lineas en Procedure Registro - la aplicación vuelve a ejecutarse múltiples veces con lo que tengo que sustituir las cadenas en cada proyecto.
¿Hay que hacer algo más?

Pues sí. En la página referida me doy cuenta que no puse toda la historia , misma que puede verse en el hilo donde el compañero seoane intervino: los mutex no admiten las diagonales invertidas, así que hay que sustituirlas por otros caracteres antes de crear el mutex.

// Saludos

[matabyte]

Buenas compañeros, subo este post ya que estoy programando una aplicación, y si bien he usado el código de román para evitar que se abran varias veces la aplicación, lo que no he conseguido hacer es enviar un mensaje junto al mutex que contenga el "paramstr" de la aplicación que se cierra a la aplicación que está funcionando.

Estoy usando Delphi 2010.

Con este código envía

Código Delphi [-]
    
var st1,txt:string;
begin
  if ParamCount>0 then
   begin
     txt:=ParamStr(0)
   end;

//Esta línea funciona
  txt:='Esta línea funciona y se recibe, el paramstr no';
  SendMessage(HWND_BROADCAST, mActivar, 0, LongWord(pchar(st1)));
end;

No se porque al escribir en la variable "txt" el texto se manda correctamente, y al intentar mandar el "paramstr" no llega nada. He pensado que era del unicode, pero he escrito cadenas en japonés y funciona

El procedimiento que me lee los datos es tal que así:

Código Delphi [-]
function AppWndProc(Handle: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LongInt; stdcall;
var
  FgThreadId  : DWORD; { Hilo de la app. que tenga el foco }
  AppThreadId : DWORD; { Hilo de nuestra aplicaci        }
  txtchar;
  st,st2:string;
  fichero_uso,listo:boolean;
  b:integer;

begin
  if Msg = mActivar then
  begin
         txt := Pchar(LParam);
         st:=txt;
         if fileexists(st) then....   
  end;
end;

Como digo, llega la cadena escrita a mano, pero nada del paramstr, sabeis alguna manera?? Gracias.

[matabyte]

Me respondo después de muchísimas horas de búsqueda-intento-error.

He utilizado el GlobalGetName junto con el método de roman para poder pasar mensajes de una aplicación a otra con un único UID (si no, se manda a todas las ventanas el mensaje). He de decir que he conseguido mandar caracteres unicode con la versión llamada "GlobalGetAtomNamew" y "GlobalAddAtomw"

Aquí el procedimiento que manda el mensaje:

Código Delphi [-]
procedure Activar;
var
 txt:string;
 wparam:integer;
begin
  if ParamCount>0 then
   begin
     txt:=ParamStr(1)
   end
  else txt:='';

  wParam:=GlobalAddAtomw(pchar(txt));
  SendMessage(HWND_BROADCAST, mActivar, wParam, length(txt));
end;

Y aquí el que lo recibe

Código Delphi [-]
function AppWndProc(Handle: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LongInt; stdcall;
var
 st:string;
begin
  if Msg = mActivar then
  begin
      try
        setlength(st,lParam);
       GlobalGetAtomNamew(wParam,pchar(st),lParam);
       setlength(st,lParam);
      finally
        GlobalDeleteAtom(wParam);
      end;    
      if fileexists(st) then
       begin
          ....
       end;     
  end;
end;

Espero que os sirva tan bien como a mi