jclappinst.pas

East make Tray Icon in delphi

  if ExplicitUniqueAppId <> '' then
    UniqueAppID := JclAIPrefix + ExplicitUniqueAppId
  else
    UniqueAppID := AnsiUpperCase(JclAIPrefix + ParamStr(0));
  CharReplace(UniqueAppID, '\', '_');
  FOptex := TJclOptex.Create(UniqueAppID + JclAIOptex, 4000);
  FOptex.Enter;
  try
    FMapping := TJclSwapFileMapping.Create(UniqueAppID + JclAIMapping,
      PAGE_READWRITE, SizeOf(TJclAISharedData), nil);
    FMappingView := FMapping.Views[FMapping.Add(FILE_MAP_ALL_ACCESS, SizeOf(TJclAISharedData), 0)];
    if not FMapping.Existed then
      FillChar(FMappingView.Memory^, SizeOf(TJclAISharedData), #0);
  finally
    FOptex.Leave;
  end;
  FMessageID := RegisterWindowMessage(PChar(UniqueAppID + JclAIMessage));
end;

class procedure TJclAppInstances.KillInstance;
begin
  Halt(0);
end;

procedure TJclAppInstances.NotifyInstances(const W, L: Integer);
var
  I: Integer;
  Wnd: HWND;
  TID: DWORD;
  Msg: TMessage;

  function EnumWinProc(Wnd: HWND; Message: PMessage): BOOL; stdcall;
  begin 
    with Message^ do
      SendNotifyMessage(Wnd, Msg, WParam, LParam);
    Result := True;
  end;

begin
  FOptex.Enter;
  try
    with PJclAISharedData(FMappingView.Memory)^ do
      for I := 0 to Count - 1 do
      begin
        Wnd := GetApplicationWnd(ProcessIDs[I]);
        TID := GetWindowThreadProcessId(Wnd, nil);
        while Wnd <> 0 do
        begin // Send message to TApplication queue
          if PostThreadMessage(TID, FMessageID, W, L) or
            (GetLastError = ERROR_INVALID_THREAD_ID) then
            Break;
          Sleep(1);
        end;
        Msg.Msg := FMessageID;
        Msg.WParam := W;
        Msg.LParam := L;
        EnumThreadWindows(TID, @EnumWinProc, LPARAM(@Msg));
      end;
  finally
    FOptex.Leave;
  end;
end;

procedure TJclAppInstances.RemoveInstance;
var
  I: Integer;
begin
  FOptex.Enter;
  try
    with PJclAISharedData(FMappingView.Memory)^ do
      for I := 0 to Count - 1 do
        if ProcessIDs[I] = FCPID then
        begin
          ProcessIDs[I] := 0;
          Move(ProcessIDs[I + 1], ProcessIDs[I], (Count - I) * SizeOf(DWORD));
          Dec(Count);
          Break;
        end;
  finally
    FOptex.Leave;
  end;
  NotifyInstances(AI_INSTANCEDESTROYED, Integer(FCPID));
end;

function TJclAppInstances.SendCmdLineParams(const WindowClassName: string; const OriginatorWnd: HWND): Boolean;
var
  TempList: TStringList;
  I: Integer;
begin
  TempList := TStringList.Create;
  try
    for I := 1 to ParamCount do
      TempList.Add(ParamStr(I));
    Result := SendStrings(WindowClassName, AppInstCmdLineDataKind, TempList, OriginatorWnd);
  finally
    TempList.Free;
  end;
end;

function TJclAppInstances.SendData(const WindowClassName: string;
  const DataKind: TJclAppInstDataKind;
  Data: Pointer; const Size: Integer;
  OriginatorWnd: HWND): Boolean;
type
  PEnumWinRec = ^TEnumWinRec;
  TEnumWinRec = record
    WindowClassName: PChar;
    OriginatorWnd: HWND;
    CopyData: TCopyDataStruct;
    Self: TJclAppInstances;
  end;

var
  EnumWinRec: TEnumWinRec;

  function EnumWinProc(Wnd: HWND; Data: PEnumWinRec): BOOL; stdcall;
  var
    ClassName: array [0..200] of Char;
    I: Integer;
    PID: DWORD;
    Found: Boolean;
  begin
    if (GetClassName(Wnd, ClassName, SizeOf(ClassName)) > 0) and
      (StrComp(ClassName, Data.WindowClassName) = 0) then
    begin
      GetWindowThreadProcessId(Wnd, @PID);
      Found := False;
      Data.Self.FOptex.Enter;
      try
        with PJclAISharedData(Data.Self.FMappingView.Memory)^ do
          for I := 0 to Count - 1 do
            if ProcessIDs[I] = PID then
            begin
              Found := True;
              Break;
            end;
      finally
        Data.Self.FOptex.Leave;
      end;
      if Found then
        SendMessage(Wnd, WM_COPYDATA, Data.OriginatorWnd, LPARAM(@Data.CopyData));
    end;
    Result := True;
  end;

begin
  Assert(DataKind <> AppInstDataKindNoData);
  EnumWinRec.WindowClassName := PChar(WindowClassName);
  EnumWinRec.OriginatorWnd := OriginatorWnd;
  EnumWinRec.CopyData.dwData := DataKind;
  EnumWinRec.CopyData.cbData := Size;
  EnumWinRec.CopyData.lpData := Data;
  EnumWinRec.Self := Self;
  Result := EnumWindows(@EnumWinProc, Integer(@EnumWinRec));
end;

function TJclAppInstances.SendString(const WindowClassName: string;
  const DataKind: TJclAppInstDataKind; const S: string;
  OriginatorWnd: HWND): Boolean;
begin
  Result := SendData(WindowClassName, DataKind, PChar(S), Length(S) + 1,
    OriginatorWnd);
end;

function TJclAppInstances.SendStrings(const WindowClassName: string;
  const DataKind: TJclAppInstDataKind; const Strings: TStrings;
  OriginatorWnd: HWND): Boolean;
var
  S: string;
begin
  S := Strings.Text;
  Result := SendData(WindowClassName, DataKind, Pointer(S), Length(S), OriginatorWnd);
end;

class function TJclAppInstances.SetForegroundWindow98(const Wnd: HWND): Boolean;
var
  ForeThreadID, NewThreadID: DWORD;
begin
  if GetForegroundWindow <> Wnd then
  begin
    ForeThreadID := GetWindowThreadProcessId(GetForegroundWindow, nil);
    NewThreadID := GetWindowThreadProcessId(Wnd, nil);
    if ForeThreadID <> NewThreadID then
    begin
      AttachThreadInput(ForeThreadID, NewThreadID, True);
      Result := SetForegroundWindow(Wnd);
      AttachThreadInput(ForeThreadID, NewThreadID, False);
      if Result then
        Result := SetForegroundWindow(Wnd);
    end
    else
      Result := SetForegroundWindow(Wnd);
  end
  else
    Result := True;
end;

function TJclAppInstances.SwitchTo(const Index: Integer): Boolean;
begin
  Result := BringAppWindowToFront(AppWnds[Index]);
end;

procedure TJclAppInstances.UserNotify(const Param: Integer);
begin
  NotifyInstances(AI_USERMSG, Param);
end;

function JclAppInstances: TJclAppInstances;
begin
  if AppInstances = nil then
    AppInstances := TJclAppInstances.Create;
  Result := AppInstances;
end;

function JclAppInstances(const UniqueAppIdGuidStr: string): TJclAppInstances;
begin
  Assert(AppInstances = nil);
  ExplicitUniqueAppId := UniqueAppIdGuidStr;
  Result := JclAppInstances;
end;

// Interprocess communication routines
function ReadMessageCheck(var Message: TMessage; const IgnoredOriginatorWnd: HWND): TJclAppInstDataKind;
begin
  if (Message.Msg = WM_COPYDATA) and (TWMCopyData(Message).From <> IgnoredOriginatorWnd) then
  begin
    Message.Result := 1;
    Result := TJclAppInstDataKind(TWMCopyData(Message).CopyDataStruct^.dwData);
  end
  else
  begin
    Message.Result := 0;
    Result := AppInstDataKindNoData;
  end;
end;

procedure ReadMessageData(const Message: TMessage; var Data: Pointer; var Size: Integer);
begin
  with TWMCopyData(Message) do
    if Msg = WM_COPYDATA then
    begin
      Size := CopyDataStruct^.cbData;
      GetMem(Data, Size);
      Move(CopyDataStruct^.lpData^, Data^, Size);
    end;
end;

procedure ReadMessageString(const Message: TMessage; var S: string);
begin
  with TWMCopyData(Message) do
    if Msg = WM_COPYDATA then
      SetString(S, PChar(CopyDataStruct^.lpData), CopyDataStruct^.cbData);
end;

procedure ReadMessageStrings(const Message: TMessage; const Strings: TStrings);
var
  S: string;
begin
  with TWMCopyData(Message) do
    if Msg = WM_COPYDATA then
    begin
      SetString(S, PChar(CopyDataStruct^.lpData), CopyDataStruct^.cbData);
      Strings.Text := S;
    end;
end;

initialization

finalization
  FreeAndNil(AppInstances);

// History:

// $Log: JclAppInst.pas,v $
// Revision 1.13  2005/02/24 16:34:52  marquardt
// remove divider lines, add section lines (unfinished)
//
// Revision 1.12  2004/10/17 21:00:14  mthoma
// cleaning
//
// Revision 1.11  2004/09/22 20:38:49  obones
// Removed "const" specifiers that were triggering the well known HPP generation bug in C++ Builder
//
// Revision 1.10  2004/08/01 11:40:23  marquardt
// move constructors/destructors
//
// Revision 1.9  2004/07/28 18:00:52  marquardt
// various style cleanings, some minor fixes
//
// Revision 1.8  2004/06/16 07:30:30  marquardt
// added tilde to all IFNDEF ENDIFs, inherited qualified
//
// Revision 1.7  2004/06/14 11:05:52  marquardt
// symbols added to all ENDIFs and some other minor style changes like removing IFOPT
//
// Revision 1.6  2004/05/05 07:33:49  rrossmair
// header updated according to new policy: initial developers & contributors listed
//
// Revision 1.5  2004/04/06 04:55:17  
// adapt compiler conditions, add log entry
//

end.