Как не допустить запуск второй копии программы

Written on . Posted in [Delphi] Приложение

ОГЛАВЛЕНИЕ

Решение 1

 

Алгоритм, применяемый мною:

В блоке begin..end модуля .dpr:

begin

if HPrevInst <>0 then begin
ActivatePreviousInstance;
Halt;
end;
end;

Реализация в модуле:

unit PrevInst;

interface

uses

WinProcs,
WinTypes,
SysUtils;

type
  PHWnd = ^HWnd;

function EnumApps(Wnd: HWnd; TargetWindow: PHWnd): bool; export;

procedure ActivatePreviousInstance;

implementation

function EnumApps(Wnd: HWnd; TargetWindow: PHWnd): bool;
var
ClassName : array[0..30] of char;
begin
Result := true;
if GetWindowWord(Wnd, GWW_HINSTANCE) = HPrevInst then begin
GetClassName(Wnd, ClassName, 30);
if STRIComp(ClassName,'TApplication')=0 then begin
TargetWindow^ := Wnd;
Result := false;
end;
end;
end;

procedure ActivatePreviousInstance;
var
PrevInstWnd: HWnd;
begin
PrevInstWnd := 0;
EnumWindows(@EnumApps,LongInt(@PrevInstWnd));
if PrevInstWnd <> 0 then
if IsIconic(PrevInstWnd) then
ShowWindow(PrevInstWnd,SW_Restore)
else
BringWindowToTop(PrevInstWnd);
end;

end.

 


 

Решение 2

 

Предоставленное разработчиками Delphi 2 Пачекой (Pacheco) и Тайхайрой (Teixeira) и значительно переработанное.

unit multinst;
{

Применение:
Необходимый код в исходном проекте

if InitInstance then
begin
Application.Initialize;
Application.CreateForm(TFrmSelProject, FrmSelProject);
Application.Run;
end;
Это все понятно (я надеюсь)
}


interface

uses Forms, Windows, Dialogs, SysUtils;

const
MI_NO_ERROR = 0;
MI_FAIL_SUBCLASS = 1;
MI_FAIL_CREATE_MUTEX = 2;

{ Проверка правильности запуска приложения с помощью описанных ниже функций. }
{ Количество флагов ошибок MI_* может быть более одного. }

function GetMIError: Integer;
Function InitInstance : Boolean;

implementation

const
UniqueAppStr : PChar;   {Различное для каждого приложения}

var
MessageId: Integer;
WProc: TFNWndProc = Nil;
MutHandle: THandle = 0;
MIError: Integer = 0;


function GetMIError: Integer;
begin
Result := MIError;
end;

function NewWndProc(Handle: HWND; Msg: Integer; wParam,
lParam: Longint): Longint; StdCall;
begin

  { Если это - сообщение о регистрации... }
if Msg = MessageID then begin
    { если основная форма минимизирована, восстанавливаем ее }
{ передаем фокус приложению }
if IsIconic(Application.Handle) then begin
Application.MainForm.WindowState := wsNormal;
ShowWindow(Application.Mainform.Handle, sw_restore);
end;
SetForegroundWindow(Application.MainForm.Handle);
end
{ В противном случае посылаем сообщение предыдущему окну }
else
Result := CallWindowProc(WProc, Handle, Msg, wParam, lParam);
end;

procedure SubClassApplication;
begin
{ Обязательная процедура. Необходима, чтобы обработчик }
{ Application.OnMessage был доступен для использования. }
WProc := TFNWndProc(SetWindowLong(Application.Handle, GWL_WNDPROC,
Longint(@NewWndProc)));
{ Если происходит ошибка, устанавливаем подходящий флаг }
if WProc = Nil then
MIError := MIError or MI_FAIL_SUBCLASS;
end;

procedure DoFirstInstance;
begin
SubClassApplication;
MutHandle := CreateMutex(Nil, False, UniqueAppStr);
if MutHandle = 0 then
MIError := MIError or MI_FAIL_CREATE_MUTEX;
end;

procedure BroadcastFocusMessage;
{ Процедура вызывается, если уже имеется запущенная копия Вашей программы. }
var
BSMRecipients: DWORD;
begin
  { Не показываем основную форму }
Application.ShowMainForm := False;
{ Посылаем другому приложению сообщение и информируем о необходимости }
{ перевести фокус на себя }
BSMRecipients := BSM_APPLICATIONS;
BroadCastSystemMessage(BSF_IGNORECURRENTTASK or BSF_POSTMESSAGE,
@BSMRecipients, MessageID, 0, 0);
end;

Function InitInstance : Boolean;
begin
MutHandle := OpenMutex(MUTEX_ALL_ACCESS, False, UniqueAppStr);
if MutHandle = 0 then
begin
    { Объект Mutex еще не создан, означая, что еще не создано }
{ другое приложение. }
ShowWindow(Application.Handle, SW_ShowNormal);
Application.ShowMainForm:=True;
DoFirstInstance;
result := True;
end
else
begin
BroadcastFocusMessage;
result := False;
end;
end;

initialization
begin
UniqueAppStr := Application.Exexname;
MessageID := RegisterWindowMessage(UniqueAppStr);
ShowWindow(Application.Handle, SW_Hide);
Application.ShowMainForm:=FALSE;
end;

finalization
begin
if WProc <> Nil then
    { Приводим приложение в исходное состояние }
SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(WProc));
end;
end.

 


 

Решение 3

face="Courier New" size="2"> VAR MutexHandle:THandle;
Var UniqueKey : string;

FUNCTION IsNextInstance:BOOLEAN;
BEGIN

Result:=FALSE;
MutexHandle:=0;
MutexHandle:=CREATEMUTEX( NIL,TRUE, UniqueKey);
IF MutexHandle<>0 THEN
BEGIN
IF GetLastError=ERROR_ALREADY_EXISTS THEN
BEGIN
Result:=TRUE;
CLOSEHANDLE(MutexHandle);
MutexHandle:=0;
END;
END;
END;

begin
CmdShow:=SW_HIDE;
MessageId:=RegisterWindowMessage(zAppName);
Application.Initialize;
IF IsNextInstance
THEN
PostMessage(HWND_BROADCAST, MessageId,0,0)
ELSE
BEGIN
Application.ShowMainForm:=FALSE;
Application.CreateForm(TMainForm, MainForm);
MainForm.StartTimer.Enabled:=TRUE;
Application.Run;
END;
IF MutexHandle<>0 THEN CLOSEHANDLE(MutexHandle);
end.

В MainForm вам необходимо вставить обработчик внутреннего сообщения

PROCEDURE TMainForm.OnAppMessage( VAR M:TMSG; VAR Ret:BOOLEAN );
BEGIN
IF M.Message=MessageId THEN
BEGIN
Ret:=TRUE;
// Поместить окно наверх !!!!!!!!
END;
END;

INITIALIZATION
ShowWindow(Application.Handle, SW_Hide);
END.
делфи форум