![](/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.