Progamm nur einmal starten und Parameter an erste weitergebe

[Luckie]

Hier also die lauffähige Version. Einfach diese Unit in das Projekt einbinden und die Methode TSingleInstance.OnStartUp mit eigenen Leben füllen. Nicht vergessen den Wert sTitle mit einem eigenen eindeutigen Wert zu ändern.

Gruß Hagen

Source:

Delphi-Quellcode:

unit SingleInstance; 

interface 

implementation 

uses Windows, SysUtils, Controls, Messages, Dialogs, Forms; 

type 
  TSingleInstance = class 
    class procedure WndProc(var Msg: TMessage); 
    class procedure Start; 
    class procedure Stop; 
    class function GetParamStr(P: PChar; var Param: string): PChar; 
    class function ParamCount: Integer; 
    class function ParamStr(Index: Integer): string; 

    class procedure OnStartup; 
  end; 

const 
  sTitle = 'my_ProgramXYZ$123456789';  // dieser Wert MUSS individuell angepasst werden 

class procedure TSingleInstance.OnStartup; 
// diese Methode muß mit eigenen Inhalt gefüllt werden, 
// als Beispiel wird hier die 1. Instance sichtbar gemacht 
// und der ParamStr() der 2. Instance angezeigt. 
var 
  S: String; 
  I: Integer; 
begin 
  Application.Minimize; 
  Application.Restore; 

  S := ''; 
  for I := 0 to ParamCount do 
    S := S + ParamStr(I) + #10; 
  ShowMessage(S); 
end; 

// ab hier Implementierung 

const 
  cMagic  = $BADF00D;  // dient zur Idententifizierung der Message wm_CopyData 
  cResult = $DAED; 

var 
  WndHandle: hWnd = 0;  // die 1. Instance erzeugt ein Fensterhandle 
  CmdLine: PChar = nil; // ParamStr() der 2. Instance per wm_CopyData transportiert 

class function TSingleInstance.GetParamStr(P: PChar; var Param: string): PChar; 
// diese funktion musste aus System.pas kopiert werden für unser 
// ParamStr() udn ParamCount() nötig 
var 
  Len: Integer; 
  Buffer: array[0..4095] of Char; 
begin 
  while True do 
  begin 
    while (P[0] <> #0) and (P[0] <= ' ') do Inc(P); 
    if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break; 
  end; 
  Len := 0; 
  while (P[0] > ' ') and (Len < SizeOf(Buffer)) do 
    if P[0] = '"' then 
    begin 
      Inc(P); 
      while (P[0] <> #0) and (P[0] <> '"') do 
      begin 
        Buffer[Len] := P[0]; 
        Inc(Len); 
        Inc(P); 
      end; 
      if P[0] <> #0 then Inc(P); 
    end else 
    begin 
      Buffer[Len] := P[0]; 
      Inc(Len); 
      Inc(P); 
    end; 
  SetString(Param, Buffer, Len); 
  Result := P; 
end; 

class function TSingleInstance.ParamCount: Integer; 
// diese Funktion musste aus System.pas kopiert werden für unser 
// ParamStr() und ParamCount() nötig da System.pas NICHT auf die 
// globale Variable System.CmdLine zugreift sondern per Funktion GetCommandLine() arbeitet. 
var 
  P: PChar; 
  S: string; 
begin 
  P := GetParamStr(CmdLine, S); // CmdLine statt GetCommandLine 
  Result := 0; 
  while True do 
  begin 
    P := GetParamStr(P, S); 
    if S = '' then Break; 
    Inc(Result); 
  end; 
end; 

class function TSingleInstance.ParamStr(Index: Integer): string; 
// siehe ParamCount 
var 
  P: PChar; 
  Buffer: array[0..260] of Char; 
begin 
  if Index = 0 then 
    SetString(Result, Buffer, GetModuleFileName(0, Buffer, SizeOf(Buffer))) 
  else 
  begin 
    P := CmdLine; // CmdLine statt GetCommandLine 
    while True do 
    begin 
      P := GetParamStr(P, Result); 
      if (Index = 0) or (Result = '') then Break; 
      Dec(Index); 
    end; 
  end; 
end; 

class procedure TSingleInstance.WndProc(var Msg: TMessage); 
// das ist die Fensterprocedure von WndHandle, sie empfängt innerhalb 
// der 1. Instance die wm_CopyData Message mit der CommandLine der 
// 2. Instance 
begin 
  with Msg do 
    if (Msg = wm_CopyData) and (PCopyDataStruct(lParam).dwData = cMagic) then 
    begin 
      Result := cResult; 
      CmdLine := PCopyDataStruct(lParam).lpData; 
      OnStartup; 
    end else Result := DefWindowProc(WndHandle, Msg, wParam, lParam); 
end; 

class procedure TSingleInstance.Start; 
var 
  PrevWnd: hWnd; 
  Data: TCopyDataStruct; 
begin 
  if MainInstance = GetModuleHandle(nil) then // nur in EXE's möglich, nicht in DLL's oder packages 
  begin 
    PrevWnd := FindWindow('TPUtilWindow', sTitle); // suche unser Fenster 
    if IsWindow(PrevWnd) then 
    begin 
    // 1. Instance läuft also schon, sende CommandLine an diese 
      Data.dwData := cMagic; 
      Data.cbData := StrLen(GetCommandLine) +1; 
      Data.lpData := GetCommandLine; 
      if SendMessage(PrevWnd, wm_CopyData, 0, Integer(@Data)) = cResult then Halt; 
    end; 
   // keine 1. Instance gefunden, wir sind also die 1. Instance 
    WndHandle := AllocateHWnd(WndProc); 
    SetWindowText(WndHandle, sTitle); 

// falls auch bei der 1. Instance OnStartup aufgerufen werden soll 
//    CmdLine := System.CmdLine; 
//    OnStartup; 
  end; 
end; 

class procedure TSingleInstance.Stop; 
begin 
  if IsWindow(WndHandle) then DeallocateHWnd(WndHandle); 
end; 

initialization 
  TSingleInstance.Start; 
finalization 
  TSingleInstance.Stop; 
end.

Autor: Hagen

[edit=fkerber]Neu abgespeichert wg. Syntax-Highlighting. Mfg, fkerber[/edit]