Delphi com 服务器在服务问题

Question

几年前，我在这里发布了一个关于服务中 COM 服务器的问题，而没有使用 Delphi XE2 的 SvCom 库。 那时，我继续使用 SvCom 来节省时间。 现在我回来尝试在 10.2.3 Tokyo 中使这种布局在没有 SvCom 的情况下工作。

我创建了一个最小的服务应用程序，并向其中添加了一个最小的 COM 自动化 object，它带有一个调用客户端事件的 SendText 方法。 该服务安装、启动并运行良好。 然后我创建了一个小型客户端应用程序，导入了类型库并添加了事件处理程序。 但是，当测试应用程序尝试连接到服务器时，我收到了 Server Execution Failed 错误。 我假设我在注册中遗漏了一些东西，但我发现的来自 MS 和其他地方的大量文档至少可以说是模棱两可的。 我希望有一些简洁的文档列出要设置的特定注册表项等，但我还没有找到。

这是我在服务中的注册和相关代码。 有人可以告诉我我在这里缺少什么吗？

procedure TTestServiceObj.ServiceAfterInstall(Sender: TService);
var
  Key: String;
begin
  DbgLog('Processing AfterInstall');
  //have ComServer add all its entries
  ComServer.UpdateRegistry(True);

  with TRegistry.Create do try
    //in the HKCR hive...
    RootKey := HKEY_CLASSES_ROOT;
    //add our LocalService entry
    Key := '\APPID\'+GUIDToString(CLASS_BWSvcTest);
    if OpenKey(Key, True) then begin
      WriteString('', Self.DisplayName);
      WriteString('LocalService', Self.Name);
      WriteString('ServiceParameters', '');
      CloseKey;
    end;

    //in the HKLM hive...
    RootKey := HKEY_LOCAL_MACHINE;
    //add the Description value
    Key := '\SYSTEM\CurrentControlSet\Services\' + Self.Name;
    if OpenKey(Key, False) then try
      WriteString('Description', 'Test service for COM server');
    finally
      CloseKey;
    end;

    //add the values for the Windows Application EventLog handling
    Key := '\SYSTEM\CurrentControlSet\Services\EventLog\Application\' + Self.Name;
    if OpenKey(Key, True) then try
      WriteString('EventMessageFile', ParamStr(0));
      WriteInteger('TypesSupported', 7);
    finally
      CloseKey;
    end;
  finally
    Free;
  end;
end;

procedure TTestServiceObj.ServiceBeforeUninstall(Sender: TService);
var
  Key: String;
begin
  DbgLog('Processing BeforeUninstall');
  with TRegistry.Create do try
    //in the HKCR hive...
    RootKey := HKEY_CLASSES_ROOT;
    //delete the localservice-related stuff
    Key := '\APPID\'+GUIDToString(CLASS_BWSvcTest);
    if KeyExists(Key) then
      DeleteKey(Key);

    //in the HKLM hive...
    RootKey := HKEY_LOCAL_MACHINE;
    //remove the Description
    Key := '\SYSTEM\CurrentControlSet\Services\' + Self.Name;
    if KeyExists(Key) then
      DeleteKey(Key);
    //delete the key for the Application EventLog handling
    Key := '\SYSTEM\CurrentControlSet\Services\EventLog\Application\' + Self.Name;
    if KeyExists(Key) then
      DeleteKey(Key);
  finally
    Free;
  end;

  //have ComServer remove the other entries
  ComServer.UpdateRegistry(False);
end;

procedure TTestServiceObj.ServiceCreate(Sender: TObject);
begin
  CoInitialize(nil);
end;

procedure TTestServiceObj.ServiceDestroy(Sender: TObject);
begin
  Svr := nil;
  CoUninitialize;
end;

procedure TTestServiceObj.ServiceStart(Sender: TService; var Started: Boolean);
begin
  try
    DbgLog('Getting server instance');
    Svr := CreateComObject(CLASS_BWSvcTest) as IBWSvcTest;
    DbgLog(IFF(Assigned(Svr), 'Server connected', 'Server NOT connected'));
  except
    on E:Exception do begin
      Svr := nil;
      DbgLogFmt('%s initializing COM service: %s', [E.ClassName, E.Message]);
    end;
  end;
end;

procedure TTestServiceObj.ServiceExecute(Sender: TService);
var
  LastS,H,M,S,mS: Word;
begin
  DbgLog('Processing ServiceExecute');
  //init COM
  CoInitialize(nil);
  try
    try
      //get our starting time values
      DecodeTime(Now, H,M,LastS,mS);
      //loop until stopped
      while not Terminated do begin
        Sleep(50);
        Self.ServiceThread.ProcessRequests(False);
        if (not Terminated) then begin
          //once a second, have the server send the time to the client
          DecodeTime(Now, H,M,S,mS);
          if S <> LastS then begin
            LastS := S;
            if Assigned(Svr) then try
              Svr.SendText(FormatDateTime('hh:nn:ss', Now));
            except
              on E:Exception do
                DbgLogExcept(E, 'Sending text to client');
            end;
          end;
        end;
      end;
    except
    end;
  finally
    CoUninitialize;
  end;
end;

Answer 1

原来 ComObj 单元有一个过程RegisterAsService(const ClassID, ServiceName: String); 设置 APPID{classID}\LocalService 值和 CLSID{classID}\AppID 值 - 通过设置这两个键，可以连接到服务器。

但是，没有相应的 UnregisterAsService() 过程，因此当您卸载服务时，您必须在 BeforeUninstall 事件中手动删除这两个键。

procedure TTestServiceObj.ServiceAfterInstall(Sender: TService);
var
  Key: String;
begin
  DbgLog('Processing AfterInstall');
  //have ComServer add all its entries
  ComServer.UpdateRegistry(True);
  //add the two entries necessary for COM server in a service
  RegisterAsService(GUIDToString(CLASS_BWSvcTest), Self.Name);

  //add our other registry entries
  with TRegistry.Create do try
    //in the HKLM hive...
    RootKey := HKEY_LOCAL_MACHINE;
    //add the Description value
    Key := '\SYSTEM\CurrentControlSet\Services\' + Self.Name;
    if OpenKey(Key, False) then try
      WriteString('Description', 'Test service for COM server');
    finally
      CloseKey;
    end;

    //add the values for the Windows Application EventLog handling
    Key := '\SYSTEM\CurrentControlSet\Services\EventLog\Application\' + Self.Name;
    if OpenKey(Key, True) then try
      WriteString('EventMessageFile', ParamStr(0));
      WriteInteger('TypesSupported', 7);
    finally
      CloseKey;
    end;
  finally
    Free;
  end;
end;

procedure TTestServiceObj.ServiceBeforeUninstall(Sender: TService);
var
  Key: String;
begin
  DbgLog('Processing BeforeUninstall');
  with TRegistry.Create do try
    //in the HKCR hive...
    RootKey := HKEY_CLASSES_ROOT;
    //these are the two keys added by the ComObj.RegisterAsService call
    //above, but there's no matching UnregisterXxx procedure so these
    //must be removed manually here
    Key := '\APPID\'+GUIDToString(CLASS_BWSvcTest);
    if KeyExists(Key) then
      DeleteKey(Key);
    Key := '\CLSID\'+GUIDToString(CLASS_BWSvcTest);
    if KeyExists(Key) then
      DeleteKey(Key);

    //have ComServer remove the other entries
    ComServer.UpdateRegistry(False);

    //in the HKLM hive...
    RootKey := HKEY_LOCAL_MACHINE;
    //remove the Description
    Key := '\SYSTEM\CurrentControlSet\Services\' + Self.Name;
    if KeyExists(Key) then
      DeleteKey(Key);
    //delete the key for the Application EventLog handling
    Key := '\SYSTEM\CurrentControlSet\Services\EventLog\Application\' + Self.Name;
    if KeyExists(Key) then
      DeleteKey(Key);
  finally
    Free;
  end;
end;