Приложение-клиент, запущенное из-под юзера SYSTEM, пытается через COM подключиться к другому приложению-серверу, запущенному под текущим залогиненным пользователем. Такое подключение клиенту не удаётся, запускается еще одна копия приложения-сервера.

Можно ли как-то подключиться к уже запущенному COM серверу?

COM работает через сообщения, а сообщения не передаются между десктопами.

Понятно, была надежда обойтись малой кровью. Как лучше выполнить взаимодействие приложения с сервисом?

Нашел:

http://www.delphimaster.ru/articles/named_pipes/

" Именованные каналы являются наиболее простым способом организации связи между сервисами и пользовательскими приложениями, нуждающимися в такой связи."

Спасибо, Игорь, за статью, буду разбираться.

Нашел еще такое:

Создание именованых каналов. Автор: Стас "Hexorg" Пономарёв.

http://forum.sources.ru/index.php?showtopic=140047

Сделал из этого более удобоваримый класс, не могу понять, почему приходит мусор в буфере в этой строке:




Весь класс:

Как объявлен TDAByte ?

> COM работает через сообщения, а сообщения не передаются
> между десктопами.

В огороде бузина, а в Киеве дядя

> _oIo_   (27.07.10 20:42) [6]
>
>
> > COM работает через сообщения, а сообщения не передаются
> > между десктопами.
>
> В огороде бузина, а в Киеве дядя
>

А на ДМ новый аноним.

TDAByte = TBytes.

Окончательный вариант на данный момент, в предыдущей версии какие-то особенности с указателями на TBytes и разыменованием были, скорее всего, лень было разбираться в ассемблере, переделал на буфер-строку:

Замечена одна особенность.

Вероятнее всего, какой-то вызов API в TPipeThread.SendToPipe выполняется асинхронно. Предполагаю, что WriteFile. Из-за этого появляется проблема, когда TPipeThread.SendToPipe вызывается несколько раз подряд. CreateFile при быстром повторном вызове возвращает INVALID_HANDLE_VALUE, LastError - все копии канала уже заняты или что-то такое.
Как исправить - не знаю, пока что убрал множественные вызовы TPipeThread.SendToPipe, но проблема осталась.

Финальный вариант, если кому-то интересно:

Еще небольшие исправления...

unit PipeThread;

{
Original idea (c) 2006 Стас "Hexorg" Пономарёв.
http://forum.sources.ru/index.php?showtopic=140047
Some fixes and improvements (c) 2010 Dmitry Belkevich
http://makhaon.com
}

interface

uses
Classes, Windows, SysUtils;

type
TPipeData = array[0..1023] of AnsiChar;

TPipeThread = class(TThread)
private
 FPipeData:       TPipeData;
 FPipeDataLength: DWord;
 FOnDataReceived: TNotifyEvent;
 FPipeName:       string;
 procedure DoDataReceived;
 function GetPipeData: string;
protected
 procedure Execute; override;
public
 constructor Create(const PipeName: string; CreateSuspended: boolean);
 destructor Destroy; override;
 class function SendToPipe(const PipeName, s: string): integer;
 class function CreatePipe(const PipeName: string): THandle;
 class function PipeExists(const PipeName: string): boolean;
 property OnDataReceived: TNotifyEvent Read FOnDataReceived Write FOnDataReceived;
 property PipeData: string Read GetPipeData;
end;

implementation

{ TPipeThread }

constructor TPipeThread.Create(const PipeName: string; CreateSuspended: boolean);
begin
FPipeName := PipeName;
inherited Create(CreateSuspended);
end;

class function TPipeThread.CreatePipe(const PipeName: string): THandle;
var
PSD: PSecurityDescriptor;
Sa:  TSecurityAttributes;
begin
PSD := PSecurityDescriptor(LocalAlloc(LPTR, SECURITY_DESCRIPTOR_MIN_LENGTH));
if not Assigned(PSD) then
 RaiseLastOSError;
if not InitializeSecurityDescriptor(PSD, SECURITY_DESCRIPTOR_REVISION) then
 RaiseLastOSError;
// Добавить NULL ACL к дескриптору безопасности
if not SetSecurityDescriptorDacl(PSD, True, nil, False) then
 RaiseLastOSError;
Sa.nLength := SizeOf(Sa);
Sa.lpSecurityDescriptor := PSD;
Sa.bInheritHandle := True;
Result := CreateNamedPipe(PChar('\\.\PIPE\' + PipeName), //Наше имя
 PIPE_ACCESS_INBOUND,          // сервер может только читать канал
 PIPE_WAIT or                  // Синхронная работа
 PIPE_READMODE_MESSAGE or      // метод чтения - пакеты
 PIPE_TYPE_MESSAGE, PIPE_UNLIMITED_INSTANCES,    // Бесконечно много клиентов
 1024,          //размер буфера чтения
 1024,          // размер буфера записи
 100,                          // Тайм-аут
 @Sa);                         // Артрибуты безопасности.
end;

destructor TPipeThread.Destroy;
begin
Terminate;
PipeExists(FPipeName);
inherited;
end;

procedure TPipeThread.DoDataReceived;
begin
if Assigned(FOnDataReceived) then
 FOnDataReceived(Self);
end;

procedure TPipeThread.Execute;
var
Pipe: THandle;
begin
Pipe := CreatePipe(FPipeName);
if Pipe = INVALID_HANDLE_VALUE then
 RaiseLastOSError;
while True do
 try
  //Подключаемся к каналу, второй параметр нужен только, если вместо PIPE_WAIT вы указали PIPE_NOWAIT
  ConnectNamedPipe(Pipe, nil);
  if Terminated then
   Break;
  //Теперь читаем, параметры – указатель на канал, наш буфер, кол-во прочитанных байт, и последнее опять таки только для PIPE_NOWAIT.
  if ReadFile(Pipe, FPipeData, 1024, FPipeDataLength, nil) then
   Synchronize(DoDataReceived);
 finally
  DisconnectNamedPipe(Pipe);
 end;
end;

function TPipeThread.GetPipeData: string;
begin
Result := Copy(string(FPipeData), 1, FPipeDataLength);
end;

class function TPipeThread.PipeExists(const PipeName: string): boolean;
begin
Result := SendToPipe(PipeName, 'test') <> 0;
end;

class function TPipeThread.SendToPipe(const PipeName, s: string): integer;
var
Pipe: THandle;
FullPipeName: PChar;
BytesWritten: DWORD;
Data: TPipeData;

procedure OpenPipe;
begin
 Pipe := CreateFile(FullPipeName, GENERIC_WRITE,          //Только запись
  FILE_SHARE_READ or      // Обмениваемся чтенью\записью
  FILE_SHARE_WRITE, nil,  //Артрибуты безопасности
  OPEN_EXISTING,          // Канал должен быть создан
  0, 0);
end;

begin
StrPLCopy(Data, ansistring(s), Length(s));
Result := 0;
FullPipeName := PChar('\\.\PIPE\' + PipeName);
OpenPipe;
if GetLastError = ERROR_PIPE_BUSY then
begin
 WaitNamedPipe(FullPipeName, 2000);
 OpenPipe;
end;
if Pipe = INVALID_HANDLE_VALUE then
 Exit;
if WriteFile(Pipe, Data, Length(s), BytesWritten, nil) then
begin
 DisconnectNamedPipe(Pipe); //Если удачно записали, закрываем канал.
 Result := BytesWritten;
end;
end;

end.

Некроман?