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

Question

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

有人有示例代码吗？

Answer 1

我们通过创建 TService 后代并添加“InstanceName”属性来完成此操作。这会在命令行上传递为类似于 ... instance="MyInstanceName"的内容，并在 SvcMgr.Application.Run 之前进行检查和设置(如果存在)。

例如 项目1.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/卸载 [-instance="MyInstanceName]
它实际上不执行任何操作 - 由您来编写启动/停止服务器位等。

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

这允许同时运行任意数量的服务实例，它们将在服务管理器中显示为“MyService”、“MyService (Inst1)”、“MyService (AnotherInstance)”等。