Instance

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

Решение 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

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.

[000022]

Содержание раздела