应用程序同时处理参数的单一实例？

2024-05-31 • 问答

我希望我的应用程序只有一个实例，并能处理新触发的实例的参数。我想使用参数，并根据这些参数进行一些处理。

我在相关问题上尝试了大卫·赫弗南（David Heffernan）的answer，但在FMX和Delphi Rio文档中没有发现与TCreateParams相关的任何内容。

无法在此处发表评论，因为我没有声誉。

program StartupProject;

uses
  SysUtils,Messages,Windows,Forms,Form3 in 'firetest.pas' {MainForm};

{$R *.res}

procedure Main;
var
  i: Integer;
  Arg: string;
  Window: HWND;
  CopyDataStruct: TCopyDataStruct;
begin
  Window := FindWindow(SWindowClassname,nil);
  if Window=0 then begin
    Application.Initialize;
    Application.MainFormOnTaskbar := True;
    Application.CreateForm(TMainForm,MainForm);
    Application.Run;
  end else begin
    FillChar(CopyDataStruct,Sizeof(CopyDataStruct),0);
    for i := 1 to ParamCount do begin
      Arg := ParamStr(i);
      CopyDataStruct.cbdata := (Length(Arg)+1)*SizeOf(Char);
      CopyDataStruct.lpData := pchar(Arg);
      SendMessage(Window,WM_COPYDATA,NativeInt(@CopyDataStruct));
    end;
    setforegroundWindow(Window);
  end;
end;

begin
  Main;
end.

unit fireTest;

interface

uses
  ...

type
  TForm3 = class(TForm)       
    procedure FormCreate(Sender: TObject);
  public
    procedure ProcessArgument(const Arg: string);
{ Public declarations }
  protected
  procedure WMCopyData(var Message: TWMCopyData); message WM_COPYDATA;

var
  Form3: TForm3;


implementation

{$R *.dfm}

{ TMainForm }

procedure TForm3.FormCreate(Sender: TObject);
var
  i: Integer;
begin
  for i := 1 to ParamCount do begin
    ProcessArgument(ParamStr(i));
  end;
end;

procedure TForm3.ProcessArgument(const Arg: string);
begin
  Memo1.Lines.Add(arg);
end;

procedure TForm3.WMCopyData(var Message: TWMCopyData);
var
  Arg: string;
begin
  SetString(Arg,pchar(Message.CopyDataStruct.lpData),(Message.CopyDataStruct.cbdata div SizeOf(Char))-1);
  ProcessArgument(Arg);
  //Application.Restore;
  //Application.BringToFront;
end;

end.

所示方法仅适用于VCL应用程序。我在Windows和MacOS下运行的Crossplatform Firemonkey应用程序中使用以下方法：

type
  TApplicationItem = record
    AppName: string;
    PID: cardinal;
  end;

{$IFDEF MSWINDOWS}
procedure GetRunningApplications(Applist: TList<TApplicationItem>);
var
 PE: TProcessEntry32;
 Snap: THandle;
 RunningPID: cardinal;
begin
  Applist.Clear;
  RunningPID := GetCurrentProcessId;
  pe.dwsize := sizeof(PE);
  Snap:= CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS,0);
  if Snap <> 0 then
  begin
    if Process32First(Snap,PE) then
    begin
      if PE.th32ProcessID <> RunningPID then
        Applist.Add(TApplicationItem.Create(
          ChangeFileExt(string(PE.szExeFile),''),PE.th32ProcessID));
      while Process32Next(Snap,PE) do
      begin
        if PE.th32ProcessID <> RunningPID then
          Applist.Add(TApplicationItem.Create(
            ChangeFileExt(string(PE.szExeFile),PE.th32ProcessID));
      end;
    end;
    CloseHandle(Snap);
  end;
end;

function ReactivateApplication(App: TApplicationItem): boolean;
  procedure GetAllWindowsForPID(PID: cardinal; WinList: TList<THandle>);
  var
    hWnd: THandle;
    WndPID: cardinal;
  begin
    hWnd := 0;
    repeat
      hWnd := FindWindowEx(0,hWnd,nil,nil);
      if hWnd <> 0 then
      begin
        GetWindowThreadProcessId(hWnd,WndPID);
        if WndPID = PID then
          WinList.Add(hWnd);
      end;
    until hWnd = 0;
  end;

var
  WinList: TList<THandle>;
  h: THandle;
begin
  result := false;
  WinList := TList<THandle>.Create;
  try
    GetAllWindowsForPID(App.PID,WinList);
    for h in WinList do
      if SetForegroundWindow(h) then
        result := true;
  finally
    WinList.Free;
  end;
end;
{$ENDIF}
{$IFDEF MACOS}
...
{$ENDIF}

function CheckForSingleAppInstance(const ThisAppName: string): boolean;
var
  AppList: TList<TApplicationItem>;
  App: TApplicationItem;
begin
  result := false;
  for App in AppList do
    if SameText(App.AppName,ThisAppName) then
      result := ReactivateApplication(App);
end;

DPR文件中的用法：

program ...;
uses 
  ...
begin
  if CheckForSingleAppInstance('YourApplicationNameWithoutExtension') then
   exit;
  Application.Initialize;
  Application.CreateForm(...);
  Application.Run;
end.

这种方法的缺点是，如果应用程序几乎同时启动，则此后它仍可能运行两个应用程序。因为第一个应用程序已经在运行，但是它们的窗口尚未出现在窗口列表中。为防止这种情况，您可以如下更改CheckForSingleAppInstance：

function CheckForSingleAppInstance(const ThisAppName: string): boolean;
var
  AppList: TList<TApplicationItem>;
  App: TApplicationItem;
begin
  result := false;
  for App in AppList do
    if SameText(App.AppName,ThisAppName) then
    begin
      ReactivateApplication(App);
      exit(true);
    end;
end;

第二种解决方案的缺点是，可能仍然挂起的第一个应用程序始终会阻止第二个实例的启动。

应用程序同时处理参数的单一实例？

a191387072 回答：应用程序同时处理参数的单一实例？

大家都在问