Советы по Delphi
         

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


Решение 1

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

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

begin
if HPrevInst <>0 then beginActivatePreviousInstance;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 beginGetClassName(Wnd, ClassName, 30);if STRIComp(ClassName,'TApplication')=0 then beginTargetWindow^ := Wnd;Result := false;end;end;end;

procedure ActivatePreviousInstance;
var
PrevInstWnd: HWnd;begin
PrevInstWnd := 0;EnumWindows(@EnumApps,LongInt(@PrevInstWnd));if PrevInstWnd <> 0 thenif IsIconic(PrevInstWnd) thenShowWindow(PrevInstWnd,SW_Restore)elseBringWindowToTop(PrevInstWnd);end;

end.

Решение 2

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

unit multinst;
{
Применение:Необходимый код в исходном проекте
if InitInstance thenbeginApplication.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 beginApplication.MainForm.WindowState := wsNormal;ShowWindow(Application.Mainform.Handle, sw_restore);end;SetForegroundWindow(Application.MainForm.Handle);end{ В противном случае посылаем сообщение предыдущему окну }elseResult := CallWindowProc(WProc, Handle, Msg, wParam, lParam);end;

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

procedure DoFirstInstance;
begin
SubClassApplication;MutHandle := CreateMutex(Nil, False, UniqueAppStr);if MutHandle = 0 thenMIError := 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 thenbegin { Объект Mutex еще не создан, означая, что еще не создано }
{ другое приложение. }ShowWindow(Application.Handle, SW_ShowNormal);Application.ShowMainForm:=True;DoFirstInstance;result := True;endelsebeginBroadcastFocusMessage;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.
<
/p> Решение 3

VAR MutexHandle:THandle;
Var UniqueKey : string;

FUNCTION IsNextInstance:BOOLEAN;
BEGIN
Result:=FALSE;
MutexHandle:=0;MutexHandle:=CREATEMUTEX( NIL,TRUE, UniqueKey);IF MutexHandle<>0 THENBEGINIF GetLastError=ERROR_ALREADY_EXISTS THENBEGINResult:=TRUE;CLOSEHANDLE(MutexHandle);MutexHandle:=0;END;END;END;

begin
CmdShow:=SW_HIDE;MessageId:=RegisterWindowMessage(zAppName);Application.Initialize;IF IsNextInstanceTHENPostMessage(HWND_BROADCAST, MessageId,0,0)ELSEBEGINApplication.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 THENBEGINRet:=TRUE;// Поместить окно наверх !!!!!!!!
END;END;

INITIALIZATION
ShowWindow(Application.Handle, SW_Hide);END.
[000022]
program Previns;usesWinTypes,WinProcs,SysUtils,Forms,Uprevins in 'UPREVINS.PAS' {Form1};{$R *.RES}
typePHWND = ^HWND;
function EnumFunc(Wnd:HWND; TargetWindow:PHWND): bool; export;varClassName : array[0..30] of char;beginResult := true;if GetWindowWord(Wnd,GWW_HINSTANCE) = hPrevInst thenbeginGetClassName( Wnd, ClassName, 30 );if StrIComp( ClassName, 'TApplication' ) = 0 thenbeginTargetWindow^ := Wnd;Result := false;end;end;end;
procedure GotoPreviousInstance;varPrevInstWnd : HWND;beginPrevInstWnd := 0;EnumWindows( @EnumFunc, Longint( @PrevInstWnd ) );if PrevInstWnd <> 0 thenif IsIconic( PrevInstWnd ) thenShowWindow( PrevInstWnd, SW_RESTORE )elseBringWindowToTop( PrevInstWnd );end;
beginif hPrevInst <> 0 thenGotoPreviousInstanceelsebeginApplication.CreateForm(TForm1, Form1);Application.Run;end;end.
[000423]


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