mORMot Open Source

igors233

Member

Registered: 2012-09-10

Posts: 241

EnsureSingleInstance not working correctly

EnsureSingleInstance finds previous instance by looking for match in Classname and Application.Title, in newer Delphi versions that doesn't work.

When Application.MainFormOnTaskbar is True, task bar button will have MainForm.Caption instead of Application.Title so there won't be any match. For that reason it's not possible to match on that (because from EnsureSingleInstance main form caption is still not known), it's better to use ProcessFileName.

Also GetClassName call fails because it's passing number of bytes, not number of chars, so correct call should be:
GetClassName(Wnd, WndClass, Pred(SizeOf(WndClass) div SizeOf(Char)));

And Halt should be placed outside of matched Class/Text block (because sometimes there wont'b e a match).

Here is updated version that takes into account these things.

procedure EnsureSingleInstance;
var
  Wnd: HWnd;
  WndClass: array[byte] of char;
  ToFindClass, AppFileName: string;

  function GetProcFileNameFromWnd(const AWnd: HWND): string;
  var
    ProcessID: DWORD;
    hProc: THandle;
  begin
    Result := '';
    GetWindowThreadProcessId(AWnd, @ProcessId);
    hProc := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, FALSE, ProcessId);
    if hProc <> 0 then
    begin
      SetLength(Result, MAX_PATH);
      Result[1] := #0;
      GetModuleFileNameEx(hProc, 0, PChar(Result), MAX_PATH);
      CloseHandle(hProc);

      Result := PChar(Result);
      Result := ExtractFileName(Result);
    end;
  end;

begin
  if Application = nil then
    Exit;

  { Try and create a semaphore. If we succeed, then check }
  { if the semaphore was already present. If it was }
  { then a previous instance is floating around. }
  { Note the OS will free the returned semaphore handle }
  { when the app shuts so we can forget about it }
  AppFileName := ExtractFileName(Application.ExeName);
  if (CreateSemaphore(nil, 0, 1, Pointer(AppFileName)) <> 0) and (GetLastError = ERROR_ALREADY_EXISTS) then
  begin
    GetClassName(Application.Handle, WndClass, SizeOf(WndClass) div SizeOf(Char) - 1);
    ToFindClass := WndClass;

    Wnd := GetWindow(Application.Handle, GW_HWNDFIRST);
    while Wnd <> 0 do begin
      { Look for the other TApplication window out there }
      if Wnd <> Application.Handle then
      begin
        { Check if got the same class and filename }
        GetClassName(Wnd, WndClass, Length(ToFindClass) + 1);
        if (ToFindClass = WndClass) and (AppFileName = GetProcFileNameFromWnd(Wnd)) then
        begin
          { This technique is used by the VCL: post }
          { a message then bring the window to the }
          { top, before the message gets processed }
          PostMessage(Wnd, WM_SYSCOMMAND, SC_RESTORE, 0);
          SetForegroundWindow(Wnd);
          Break;
        end
      end;

      Wnd := GetWindow(Wnd, GW_HWNDNEXT);
    end;

    Halt; // Stop this new instance
  end
end;

ab

Administrator

From: France

Registered: 2010-06-21

Posts: 14,666

Website

Re: EnsureSingleInstance not working correctly

Should be fixed by http://synopse.info/fossil/info/c208da7d5d

Thanks for the feedback!