Delphi com server in service problems

Question

Some years ago I posted a question here about COM servers in services without using the SvCom library for Delphi XE2. Back then, I went ahead and used SvCom to save time. Now I'm back trying to make this layout work without SvCom in 10.2.3 Tokyo.

I've created a minimal service app, and added to it a minimal COM automation object with a SendText method that calls a client event. The service installs, starts and runs fine. I then created a small client app, imported the type library and added the event handler. But when the test app attempts to connect to the server, I get a Server Execution Failed error. I'm assuming I've missed something in the registration, but the mass of documentation from MS and elsewhere that I've found is ambiguous to say the least. I'd hoped there would be some concise doc that listed the specific registry entries, etc. to set up, but I haven't found it.

This is my registration and related code in the service. Can someone tell me what I'm missing here?


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;

you are creating the com server in another thread context (servicestart does not run under the same thread as serviceexecute), try moving the comserver creating code into serviceexecute — whosrdaddy
I thought TAutoObjectFactory created the server in the initialization of the server implementation unit; the CreateComObject call was just to get an interface to it to call the SendText method. Should I call something else to get the interface? — SteveS

SteveS SteveS · Accepted Answer · 2020-06-16T19:02:58

Turns out that the ComObj unit has a procedure RegisterAsService(const ClassID, ServiceName: String); that sets both the APPID{classID}\LocalService value and the CLSID{classID}\AppID value - with these two keys set, the server can be connected to.

However, there is no corresponding UnregisterAsService() procedure, so when you uninstall the service you must delete both of those keys manually in the BeforeUninstall event.


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;

Delphi com server in service problems

1 Answers