Este truco lo encontre navegando por internet y fue uno de esos descubribientos al azar con los que a veces uno se topa. El objetivo del siguiente codigo es evitar que nuestro programa sea abierto mas de una vez en el ordenador. Es decir evitar multiples instancias de nuestro programa.
Primero creen una nueva Unit y coloquen el siguiente codigo dentro de ella
Código Delphi
[-]
unit CheckPrevious;
interface
uses Windows, SysUtils;
function RestoreIfRunning(const AppHandle : THandle; MaxInstances : integer = 1) : boolean;
implementation
type
PInstanceInfo = ^TInstanceInfo;
TInstanceInfo = packed record
PreviousHandle : THandle;
RunCounter : integer;
end;
var
MappingHandle: THandle;
InstanceInfo: PInstanceInfo;
MappingName : string;
RemoveMe : boolean = True;
function RestoreIfRunning(const AppHandle : THandle; MaxInstances : integer = 1) : boolean;
begin
Result := True;
MappingName :=StringReplace(ParamStr(0),'\','',[rfReplaceAll, rfIgnoreCase]);
MappingHandle := CreateFileMapping($FFFFFFFF,
nil,
PAGE_READWRITE,
0,
SizeOf(TInstanceInfo),
PChar(MappingName));
if MappingHandle = 0 then
RaiseLastOSError
else
begin
if GetLastError <> ERROR_ALREADY_EXISTS then
begin
InstanceInfo := MapViewOfFile(MappingHandle,
FILE_MAP_ALL_ACCESS,
0,
0,
SizeOf(TInstanceInfo));
InstanceInfo^.PreviousHandle := AppHandle;
InstanceInfo^.RunCounter := 1;
Result := False;
end
else begin
MappingHandle := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(MappingName));
if MappingHandle <> 0 then
begin
InstanceInfo := MapViewOfFile(MappingHandle,
FILE_MAP_ALL_ACCESS,
0,
0,
SizeOf(TInstanceInfo));
if InstanceInfo^.RunCounter >= MaxInstances then
begin
RemoveMe := False;
if IsIconic(InstanceInfo^.PreviousHandle) then
ShowWindow(InstanceInfo^.PreviousHandle, SW_RESTORE);
SetForegroundWindow(InstanceInfo^.PreviousHandle);
end
else
begin
InstanceInfo^.PreviousHandle := AppHandle;
InstanceInfo^.RunCounter := 1 + InstanceInfo^.RunCounter;
Result := False;
end
end;
end;
end;
end;
initialization
finalization
if RemoveMe then
begin
MappingHandle := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(MappingName));
if MappingHandle <> 0 then
begin
InstanceInfo := MapViewOfFile(MappingHandle,
FILE_MAP_ALL_ACCESS,
0,
0,
SizeOf(TInstanceInfo));
InstanceInfo^.RunCounter := -1 + InstanceInfo^.RunCounter;
end
else
RaiseLastOSError;
end;
if Assigned(InstanceInfo) then UnmapViewOfFile(InstanceInfo);
if MappingHandle <> 0 then CloseHandle(MappingHandle);
end.
Segundo salven la unit con el nombre
CheckPrevious
Tercero ahora deben incluirla en cualquiera de sus proyectos y hacer un agregado al codigo en el archivo de proyecto de su aplicacion como se ve aqui abajo. Recuerde que para agregar esta unit a su proyecto recomiendo copiar su archivo a la misma carpeta en la que esta su aplicacion en desarrollo y luego agregarla con
Add file to proyect pulsando en delphi 2007
SHIFT+F11
Código Delphi
[-]
program Obessologia08;
uses
Forms,
Controls,
Windows,
U_Prin in 'U_Prin.pas' ,
U_DM_Obess in 'U_DM_Obess.pas' ,
FuncionesGlobales in 'FuncionesGlobales.pas',
...
....
...
...
...
....
U_AutoresVersion in 'U_AutoresVersion.pas' ,
U_Producto in 'U_Producto.pas' ,
U_Claves in 'U_Claves.pas' ,
CheckPrevious in 'CheckPrevious.pas';
{$R *.res}
Var R: Integer;
begin
if not CheckPrevious.RestoreIfRunning(Application.Handle, 1) then begin
Application.Initialize;
Application.Title := 'Cirugía Metabólica DataSet';
Application.MainFormOnTaskbar := True;
try
F_Login:=TF_Login.Create(Application);
R :=F_Login.ShowModal;
F_Login.Free;
if R = mrOK then begin
Application.CreateForm(TDM_Obess, DM_Obess);
Application.CreateForm(TF_Prin, F_Prin);
Application.Run;
end;
if R = mrAbort then begin
FNoAdmitido:=TFNoAdmitido.Create(Application);
FNoAdmitido.ShowModal;
FNoAdmitido.Free;
F_AutoresVersion:=TF_AutoresVersion.Create(Application);
F_AutoresVersion.ShowModal;
F_AutoresVersion.Free;
Application.Terminate;
end;
finally
Application.Terminate;
end;
end;
end.
Otro ejemplo de su uso
Código Delphi
[-]
program Mailing;
uses
Forms,
Unit1 in 'Unit1.pas' ,
VCLFixPack in 'VCLFixPack.pas',
CheckPrevious in 'CheckPrevious.pas',
ThreadSendMailer in 'ThreadSendMailer.pas';
{$R *.res}
begin
if not CheckPrevious.RestoreIfRunning(Application.Handle, 1) then
begin
Application.Initialize;
Application.MainFormOnTaskbar := True;
Application.Title := 'Enviar correos por smtp';
Application.CreateForm(TForm1, Form1);
Application.Run;
end;
end.