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 = '
TESTPROGRAMM';
// 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.