Delphi中拥有相同程序的多个NT服务

Question

我正在寻找Delphi示例代码来开发可多次安装（具有不同名称）的Win32 Windows服务。 这个想法是为每个要安装的服务提供1个注册表项和1个注册表项。 我使用exe来安装/运行许多服务，每个服务从他的注册表子项中获取他的参数。

有没有人有示例代码？

Answer 1

我们通过创建一个TService后代并添加一个'InstanceName'属性来完成这项工作。这会在命令行上传递，如... instance =“MyInstanceName”，并在SvcMgr.Application.Run之前检查并设置（如果存在）。

例如 Project1.dpr：

program Project1; 

uses 
    SvcMgr, 
    SysUtils, 
    Unit1 in 'Unit1.pas' {Service1: TService}; 

{$R *.RES} 

const 
    INSTANCE_SWITCH = '-instance='; 

function GetInstanceName: string; 
var 
    index: integer; 
begin 
    result := ''; 
    for index := 1 to ParamCount do 
    begin 
    if SameText(INSTANCE_SWITCH, Copy(ParamStr(index), 1, Length(INSTANCE_SWITCH))) then 
    begin 
     result := Copy(ParamStr(index), Length(INSTANCE_SWITCH) + 1, MaxInt); 
     break; 
    end; 
    end; 
    if (result <> '') and (result[1] = '"') then 
    result := AnsiDequotedStr(result, '"'); 
end; 

var 
    inst: string; 

begin 
    Application.Initialize; 
    Application.CreateForm(TService1, Service1); 
    // Get the instance name 
    inst := GetInstanceName; 
    if (inst <> '') then 
    begin 
    Service1.InstanceName := inst; 
    end; 
    Application.Run; 
end. 

1单元（一个TService后裔）

unit Unit1; 

interface 

uses 
    Windows, SysUtils, Classes, SvcMgr, WinSvc; 

type 
    TService1 = class(TService) 
    procedure ServiceAfterInstall(Sender: TService); 
    private 
    FInstanceName: string; 
    procedure SetInstanceName(const Value: string); 
    procedure ChangeServiceConfiguration; 
    public 
    function GetServiceController: TServiceController; override; 
    property InstanceName: string read FInstanceName write SetInstanceName; 
    end; 

var 
    Service1: TService1; 

implementation 

{$R *.DFM} 

procedure ServiceController(CtrlCode: DWord); stdcall; 
begin 
    Service1.Controller(CtrlCode); 
end; 

procedure TService1.ChangeServiceConfiguration; 
var 
    mngr: Cardinal; 
    svc: Cardinal; 
    newpath: string; 
begin 
    // Open the service manager 
    mngr := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS); 
    if (mngr = 0) then 
    RaiseLastOSError; 
    try 
    // Open the service 
    svc := OpenService(mngr, PChar(Self.Name), SERVICE_CHANGE_CONFIG); 
    if (svc = 0) then 
     RaiseLastOSError; 
    try 
     // Change the service params 
     newpath := ParamStr(0) + ' ' + Format('-instance="%s"', [FInstanceName]); // + any other cmd line params you fancy 
     ChangeServiceConfig(svc, SERVICE_NO_CHANGE, // dwServiceType 
           SERVICE_NO_CHANGE, // dwStartType 
           SERVICE_NO_CHANGE, // dwErrorControl 
           PChar(newpath), // <-- The only one we need to set/change 
           nil,    // lpLoadOrderGroup 
           nil,    // lpdwTagId 
           nil,    // lpDependencies 
           nil,    // lpServiceStartName 
           nil,    // lpPassword 
           nil);    // lpDisplayName 
    finally 
     CloseServiceHandle(svc); 
    end; 
    finally 
    CloseServiceHandle(mngr); 
    end; 
end; 

function TService1.GetServiceController: TServiceController; 
begin 
    Result := ServiceController; 
end; 

procedure TService1.ServiceAfterInstall(Sender: TService); 
begin 
    if (FInstanceName <> '') then 
    begin 
    ChangeServiceConfiguration; 
    end; 
end; 

procedure TService1.SetInstanceName(const Value: string); 
begin 
    if (FInstanceName <> Value) then 
    begin 
    FInstanceName := Value; 
    if (FInstanceName <> '') then 
    begin 
     Self.Name := 'Service1_' + FInstanceName; 
     Self.DisplayName := Format('Service1 (%s)', [FInstanceName]); 
    end; 
    end; 
end; 

end. 

用法：
PROJECT1.EXE /安装
PROJECT1。EXE /安装-instance =“MyInstanceName”
PROJECT1.EXE /卸载[-instance =“MyInstanceName]
它实际上并没有做任何事情 - 这是给你写的启动/停止服务器位等

ChangeServiceConfiguration调用用于更新服务管理器在启动时调用的真实命令行，您可以直接编辑注册表，但至少这是'正确的'API方式。

这允许任何数量的要同时运行的服务实例，它们将作为“MyService”，“MyService（Inst1）”，“MyService（AnotherInstance）”等出现在服务管理器中等。

Answer 2

有关如何在Delphi中实现服务的问题，使用其他名称不易安装服务（请参阅Quality Central报告#79781）。您可能需要绕过TService/TServiceApplication实现。 要使用不同的名称创建服务，不能简单地使用/ INSTALL命令行参数，但必须使用SCM API或其一个实现（即SC.EXE命令行实用程序）或安装工具。 要告诉服务要读取哪个密钥，您可以在其命令行上将参数传递给服务（它们也有），创建服务时会设置参数。

Answer 3

上下文：通过运行exename.exe/install作为MyService安装服务。服务再次作为MyService2安装。

Delphi不允许使用不同的名称安装两次可执行文件中的服务。参见QC 79781的描述。不同的名称导致服务在“开始”阶段“挂起”（至少根据SCM）。这是因为DispatchServiceMain根据SCM（在启动服务时传入）检查TService实例名称和名称是否相等。当它们不同时DispatchServiceMain不执行TService.Main，这意味着TService的启动代码不会执行。

为了避免这种情况（有点），在Application.Run调用之前调用FixServiceNames过程。

限制：备用名称必须以原始名称开头。如果原始名称是MyService，那么你可以安装MyService1，MyServiceAlternate，MyServiceBoneyHead等。

FixServiceNames所做的是查找所有已安装的服务，检查ImagePath以查看服务是否由此可执行文件实现并收集它们名单。对已安装的ServiceName进行排序。然后检查SvcMgr.Application.Components中的所有TService后代。当以Component.Name（服务的原始名称）开头安装ServiceName时，请使用我们从SCM获取的名称替换它。

procedure FixServiceNames; 
const 
    RKEY_SERVICES = 'SYSTEM\CurrentControlSet\Services'; 
    RKEY_IMAGE_PATH = 'ImagePath'; 
    RKEY_START = 'Start'; 
var 
    ExePathName: string; 
    ServiceNames: TStringList; 
    Reg: TRegistry; 
    i: Integer; 
    ServiceKey: string; 
    ImagePath: string; 
    StartType: Integer; 
    Component: TComponent; 
    SLIndex: Integer; 
begin 
    ExePathName := ParamStr(0); 

    ServiceNames := TStringList.Create; 
    try 
    Reg := TRegistry.Create(KEY_READ); 
    try 
     Reg.RootKey := HKEY_LOCAL_MACHINE; 

     // Openen registry key with all the installed services. 
     if Reg.OpenKeyReadOnly(RKEY_SERVICES) then 
     begin 
     // Read them all installed services. 
     Reg.GetKeyNames(ServiceNames); 

     // Remove Services whose ImagePath does not match this executable. 
     for i := ServiceNames.Count - 1 downto 0 do 
     begin 
      ServiceKey := '\' + RKEY_SERVICES + '\' + ServiceNames[i]; 
      if Reg.OpenKeyReadOnly(ServiceKey) then 
      begin 
      ImagePath := Reg.ReadString(RKEY_IMAGE_PATH); 
      if SamePath(ImagePath, ExePathName) then 
      begin 
       // Only read 'Start' after 'ImagePath', the other way round often fails, because all 
       // services are read here and not all of them have a "start" key or it has a different datatype. 
       StartType := Reg.ReadInteger(RKEY_START); 
       if StartType <> SERVICE_DISABLED then 
       Continue; 
      end; 

      ServiceNames.Delete(i); 
      end; 
     end; 
     end; 
    finally 
     FreeAndNil(Reg); 
    end; 

    // ServiceNames now only contains enabled services using this executable. 
    ServiceNames.Sort; // Registry may give them sorted, but now we are sure. 

    if ServiceNames.Count > 0 then 
     for i := 0 to SvcMgr.Application.ComponentCount - 1 do 
     begin 
     Component := SvcMgr.Application.Components[i]; 
     if not (Component is TService) then 
      Continue; 

     // Find returns whether the string is found and reports through Index where it is (found) or 
     // where it should be (not found). 
     if ServiceNames.Find(Component.Name, SLIndex) then 
      // Component.Name found, nothing to do 
     else 
      // Component.Name not found, check whether ServiceName at SLIndex starts with Component.Name. 
      // If it does, replace Component.Name. 
      if SameText(Component.Name, Copy(ServiceNames[SLIndex], 1, Length(Component.Name))) then 
      begin 
      Component.Name := ServiceNames[SLIndex]; 
      end 
      else 
      ; // Service no longer in executable? 
     end; 
    finally 
    FreeAndNil(ServiceNames); 
    end; 
end; 

注：SO漂亮打印机迷糊在 “服务关键字：= '\' + RKEY_SERVICES + '\' + ServiceNames [I];”行，德尔福（2009）没有问题。