Question

我正在寻找Delphi示例代码来开发可以多次安装的Win32 Windows服务（使用不同的名称）。这个想法是为每个要安装的服务提供1个exe和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.

Unit1（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 / install -instance =“MyInstanceName”
  Project1.exe / uninstall [-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作为idsandon提到。不同的名称导致服务在“正在启动”阶段“挂起”（至少根据SCM）。这是因为DispatchServiceMain根据SCM（在启动服务时传入）检查TService实例名称和名称是否相等。当它们不同时，DispatchServiceMain不执行TService.Main，这意味着TService的启动代码不会被执行。

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

限制：替代名称必须以原始名称开头。 IE如果原始名称是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;

注意：很漂亮的打印机对“ServiceKey：='\'+ + RKEY_SERVICES +'\'+ + ServiceNames [i];”感到困惑德尔福（2009）对它没有任何问题。

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

3 个答案: