![](/img/trans.png)
[英]Is it possible to install multiple instances of the same delphi service application?
[英]Multiple instances of the same service in Delphi
我有一个旧的Windows服务在delphi中,现在必须在同一台服务器上多次安装,我正在尝试更改代码,以便我能够更改服务名称,因为我正在安装服务,但我不能使它工作。
我找了一些资料在这里 ,有的在这里一下吧,学习后的职位,并进行必要的修改,我能够安装两个服务具有不同名称,但该服务不启动。
我发布负责控制下面的服务的类(继承TService),我知道相当多的代码,但我真的很感激任何帮助。
procedure ServiceController(CtrlCode: DWord); stdcall;
begin
tvdAvalancheDataCenterService.Controller(CtrlCode);
end;
function TtvdAvalancheDataCenterService.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
procedure TtvdAvalancheDataCenterService.ServiceLoadInfo(Sender : TObject);
begin
Name := ParamStr(2);
DisplayName := ParamStr(3);
end;
procedure TtvdAvalancheDataCenterService.ServiceBeforeInstall(Sender: TService);
begin
ServiceLoadInfo(Self);
end;
procedure TtvdAvalancheDataCenterService.ServiceCreate(Sender: TObject);
begin
ServiceLoadInfo(Self);
end;
procedure TtvdAvalancheDataCenterService.ServiceStart(Sender: TService;
var Started: Boolean);
begin
FtvdTrayIcon := TtvdEnvoyTrayIcon.Create(Self);
SetServiceDescription;
FtvdDataCenter.tvdActive := true;
end;
procedure TtvdAvalancheDataCenterService.ServiceStop(Sender: TService;
var Stopped: Boolean);
begin
FreeAndNil(FtvdTrayIcon);
FtvdDataCenter.tvdActive := False;
end;
procedure TtvdAvalancheDataCenterService.ServiceAfterInstall(Sender: TService);
begin
SetServiceDescription;
end;
procedure TtvdAvalancheDataCenterService.SetServiceDescription;
var
aReg: TRegistry;
begin
if FDescriptionUpdated then
Exit;
aReg := TRegistry.Create(KEY_READ or KEY_WRITE);
try
aReg.RootKey := HKEY_LOCAL_MACHINE;
if aReg.OpenKey(cnRegKey+ Name, true) then
begin
aReg.WriteString('Description', cnServiceDescription);
aReg.CloseKey;
end;
FDescriptionUpdated:= True;
finally
aReg.Free;
end;
end;
我正在使用Delphi XE,并且该服务需要在Windows服务中运行。
提前致谢
由于服务不知道安装时收到的名称,因此您可以将该名称作为参数提供给它的ImagePath注册表值。
这是多个实例的基本服务框架:
unit u_svc_main;
interface
uses
Winapi.Windows,
System.Win.Registry,
System.SysUtils,
System.Classes,
Vcl.Dialogs,
Vcl.SvcMgr;
type
TSvc_test = class(TService)
procedure ServiceAfterInstall(Sender: TService);
procedure ServiceBeforeInstall(Sender: TService);
procedure ServiceCreate(Sender: TObject);
procedure ServiceBeforeUninstall(Sender: TService);
private
{ Private declarations }
procedure GetServiceName;
procedure GetServiceDisplayName;
public
function GetServiceController: TServiceController; override;
{ Public declarations }
end;
var
Svc_test: TSvc_test;
implementation
{$R *.dfm}
procedure TSvc_test.GetServiceDisplayName;
var
ServiceDisplayName : String;
begin
if not FindCmdLineSwitch('display', ServiceDisplayName) then
raise Exception.Create('Please specify the service displayname with /display switch');
DisplayName := ServiceDisplayName;
end;
procedure TSvc_test.GetServiceName;
var
ServiceName : String;
begin
if not FindCmdLineSwitch('name', ServiceName) then
raise Exception.Create('Please specify the service name with /name switch');
Name := ServiceName;
end;
procedure ServiceController(CtrlCode: DWord); stdcall;
begin
Svc_test.Controller(CtrlCode);
end;
function TSvc_test.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
procedure TSvc_test.ServiceAfterInstall(Sender: TService);
var
Reg : TRegistry;
ImagePath : String;
begin
Reg := TRegistry.Create(KEY_READ OR KEY_WRITE);
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.OpenKey('SYSTEM\CurrentControlSet\Services\'+Name, False) then
begin
// set service description
Reg.WriteString('Description', 'Multi instance test for service '+Name);
// add name parameter to ImagePath value
ImagePath := ParamStr(0) + ' /name '+Name;
Reg.WriteString('ImagePath', ImagePath);
Reg.CloseKey;
end;
finally
Reg.Free;
end;
end;
procedure TSvc_test.ServiceBeforeInstall(Sender: TService);
begin
GetServiceName;
GetServiceDisplayName;
end;
procedure TSvc_test.ServiceBeforeUninstall(Sender: TService);
begin
GetServiceName;
end;
procedure TSvc_test.ServiceCreate(Sender: TObject);
begin
if not Application.Installing then
GetServiceName;
end;
end.
服务安装:
<path1>\MyService.Exe /install /name "test1" /display "test instance1"
<path2>\MyService.Exe /install /name "test2" /display "test instance2"
服务搬迁:
<path1>\MyService.Exe /uninstall /name "test1"
<path2>\MyService.Exe /uninstall /name "test2"
这很简单。 您只需为每个服务设置不同的名称。
你现在有:
名称:= ParamStr(2);
DisplayName:= ParamStr(3);
只需将其更改为:
名称:= baseServiceName +' - '+ GetLastDirName;
DisplayName:= baseServiceDisplayName +'('+ GetLastDirName +')';
其中baseServiceName是一个带有服务名称的常量; baseServiceDisplayName是一个带有显示名称的常量, GetLastDirName是一个从ExtractFilePath(ParamStr(0))返回目录名称(最后一个目录)的函数
```
function GetLastDirName: string;
var
aux: string;
p: Integer;
begin
aux := strDelSlash(ExtractFilePath(ParamStr(0)));
p := StrLastPos('\', aux);
if p > 0 then
result := Copy(aux, p + 1, Length(aux))
else
result := aux;
end;
```
strDelSlash删除最后一个斜杠; StrLastPos搜索斜杠的最后位置
@whosrdaddy建议的解决方案适合我。
但是,eventviewer将记录的消息(MyService.LogMessage(...))显示为未定义或未安装。
如果名称和显示名称与设计时相同,则这些消息显示正常。 在exetubale中链接的预定义消息类型很少作为资源。
使用Eventwiver,用户可以在发生任何预定义事件时附加任何用户定义的操作。
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.