Валентин Озеров - Советы по Delphi. Версия 1.4.3 от 1.1.2001

{*******************************************************}

unit multinst;

interface

uses Forms, Windows, Dialogs, SysUtils;

const

 MI_NO_ERROR = 0;

 MI_FAIL_SUBCLASS = 1;

 MI_FAIL_CREATE_MUTEX = 2;

function GetMIError: Integer;

function InitInstance : Boolean;

implementation

uses RegWork, FileWork;

var

 UniqueAppStr : PChar;

 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

 Result := 1;

 if Msg = MessageID then begin

  if IsIconic(Application.Handle) then OpenIcon(Application.Handle)

  else SetForegroundWindow(Application.Handle);

  FileWork.LoadFileName(RegWork.RWGetParamStr1);

 end

 else Result := CallWindowProc(WProc, Handle, Msg, wParam, lParam);

end;

procedure SubClassApplication;

begin

 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;

begin

 Application.ShowMainForm := False;

 PostMessage(HWND_BROADCAST, MessageId, 0, 0);

end;

function InitInstance : Boolean;

begin

 MutHandle := OpenMutex(MUTEX_ALL_ACCESS, False, UniqueAppStr);

 if MutHandle = 0 then begin

ShowWindow(Application.Handle, SW_ShowNormal);

  Application.ShowMainForm:=True;

  DoFirstInstance;

  result := True;

 end

 else begin

  RegWork.RWSetParamStr1;

  BroadcastFocusMessage;

  result := False;

 end;

end;

initialization

begin

 UniqueAppStr := PChar(Application.ExeName);

 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.

YoungHacker рекомендует следующий код:

Был взят из кулибы и доработан, поскольку возникали ситуации когда программа, по HotKey назначенным на ярлык, запускалась дважды и более раз. Связано с тем что поиск мутекса и его создание разнесены во времени и пока в одном приложении мутекс не нашелся но еще не создался второе приложение тоже не находит мутекса и инициирует его создание

Поиск окон и создание их нарываются на те-же проблемы. Из RxLib Функция тоже не обходит этой ситуации.

Мой вариант немного дорабатывает уже значительно переработанное то что предоставили разработчики Delphi 2 Пачека (Pacheco) и Тайхайра (Teixeira). и находится в файле TPrevInstUnit. В файле проекта пишется следующий вызов:

begin

 //– Найти предыдущую версию программы

 if (initinstance) then begin

  …

  Application.Initialize;

  …

  Application.CreateForm(…);

  …

  Application.Run;

 end;

end.

unit TPrevInstUnit;

interface

uses Forms, Windows, Dialogs, SysUtils;

function InitInstance : Boolean;

implementation

const

 UniqueAppStr : PChar = #0; // Различное для каждого приложения

                            // Но одинаковое для каждой копии программы

var

 MessageId : Integer;

 OldWProc : TFNWndProc = Nil;

 MutHandle : THandle = 0;

 SecondExecution : Boolean = False;

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

begin

 //- Если это - сообщение о регистрации... }

 if (Msg = MessageID) then begin

//- если основная форма минимизирована

  if IsIconic(Application.Handle) then begin

//- восстанавливаем

   ееApplication.Restore;

  end

  else begin

//- вытаскиваем на перед

   ShowWindow(Application.Handle, SW_SHOW);

   SetForegroundWindow(Application.Handle);

   Application.BringToFront;

  end;

  Result := 0;

 end

 else

{ В противном случае посылаем сообщение предыдущему окну }

  Result := CallWindowProc(OldWProc, Handle, Msg, wParam, lParam);

end;

function InitInstance : Boolean;

var

 BSMRecipients: DWORD;

begin

 Result := False;

 //- пробуем открыть MUTEX созданный предыдущей копией программы

 MutHandle := CreateMutex(Nil, True, UniqueAppStr);

 //- Мутекс уже был создан ?

 SecondExecution := (GetLastError = ERROR_ALREADY_EXISTS);

 if (MutHandle = 0) then begin

ShowMessage('Ошибка создания Mutex.');

  Exit;

 end;

 if Not (SecondExecution) then begin

//- назначаем новый обработчик сообщений приложения, а старый сохраняем

  OldWProc := TFNWndProc(SetWindowLong(Application.Handle, GWL_WNDPROC, Longint(@NewWndProc)));

  //- если обработчик не найден устанавливаем ошибку

  if (OldWProc = Nil) then begin

ShowMessage('Ошибка поиска стандартного обработчика сообщений приложения.');

   Exit;

  end;

  //- Установить "нормальный" статус основного окна приложения

  ShowWindow(Application.Handle, SW_ShowNormal);

  //- покажем основную форму приложения

  Application.ShowMainForm := True;

  //- все нормально мама трын тин тин тин тири тын тын

  Result := True;

 end

 else begin

//- установить статус окна приложения "невидимый"

  ShowWindow(Application.Handle, SW_Hide);

  //- Не покажем основную форму приложения

  Application.ShowMainForm := False;

  //- Посылаем другому приложению сообщение и информируем о необходимости

  // перевести фокус на себя

  BSMRecipients := BSM_APPLICATIONS;

  BroadCastSystemMessage(BSF_IGNORECURRENTTASK or BSF_POSTMESSAGE, @BSMRecipients, MessageID, 0, 0);

 end;

end;

initialization

begin

 //- Создать ункальную строку для опознания приложения

 UniqueAppStr := PChar('YoungHackerNetworkDataBaseProgramm');

 //- Зарегистрировать в системе уникальное сообщение

 MessageID := RegisterWindowMessage(UniqueAppStr);

end;

finalization

begin

 if (OldWProc <> Nil) then

{ Приводим приложение в исходное состояние }

  SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(OldWProc));

 end;

end.

Nomadic рекомендует следующий код:

FindWindow является неполным решением (если меняется заголовок окна или если есть другая программа с таким же заголовком или типом окна).

Вторично: Это работает медленно.

Правильно — использовать обьекты синхронизации Win32 API.

Лениво пользовать семафоры, покажу на именованных мутексах (семафоры с двумя состояниями).

Unit OneInstance32;

interface

implementation

uses

 Forms;

var

 g_hAppMutex: THandle;

function OneInstance: boolean;

var

 g_hAppCritSecMutex: THandle;

 dw: Longint;