Delphi 中的服务申请

Question

我正在为 Delphi 中的服务应用程序苦苦挣扎，但到目前为止没有取得重大成功。我试图重新创建 this project，但它似乎无法正常工作。文件已创建，但日期和时间不会每 10 秒添加到文件中。我也没有看到从我的 ShowMessage 弹出消息。我成功安装并启动了服务应用程序。

这是我的代码：

unit TMS;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.SvcMgr, Vcl.Dialogs,
  Vcl.ExtCtrls;

type
  TWorkflow = class(TService)
    Timer1: TTimer;
    procedure ServiceExecute(Sender: TService);
    procedure Timer1Timer(Sender: TObject);
    procedure ServiceBeforeInstall(Sender: TService);
  private
    { Private declarations }
  public
    function GetServiceController: TServiceController; override;
    { Public declarations }
  end;

var
  Workflow: TWorkflow;

implementation

{$R *.dfm}

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

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

procedure TWorkflow.ServiceBeforeInstall(Sender: TService);
begin
  Interactive := True;
end;

procedure TWorkflow.ServiceExecute(Sender: TService);
begin
  while not Terminated do
  begin
    ServiceThread.ProcessRequests(True);
  end;
end;

procedure TWorkflow.Timer1Timer(Sender: TObject);
const
  FileName = 'D:\Projekti\EMBRACADERO\TMSWorkflow\Win32\Debug\Log.txt';
var
  F : TextFile;
begin
  AssignFile(F, FileName);
  if FileExists(FileName) then
    Append(F)
  else
    Rewrite(F);
  Writeln(F, DateTimeToStr(Now), ' ', DiskFree(0));
  ShowMessage(DateTimeToStr(Now));
  CloseFile(F);
end;

end.

有人可以给我一个可能包含线程的服务应用程序或包含可视组件的服务的示例吗？

更新 1：

它正在使用以下代码每 3 秒在数据库中插入一些数据。

private
    thread : TThread;  

procedure TWorkflow.InsertInDatabase;
begin
  FDTransaction1.StartTransaction;
  try
    FDQuery1.Execute;
    FDTransaction1.Commit;
  except
    FDTransaction1.Rollback;
  end;
end;

procedure TWorkflow.ServiceExecute(Sender: TService);
begin
  while not Terminated do
  begin
    ServiceThread.ProcessRequests(False);
    InsertInDatabase();
    thread.sleep(3000);
  end;
end;

procedure TWorkflow.ServiceStart(Sender: TService; var Started: Boolean);
begin
  thread := TThread.Create;
end;

procedure TWorkflow.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
  FreeAndNil(thread);
end;

Answer 1

您的计时器代码将不会执行，因为计时器依赖 window 句柄和 TService 不提供的消息泵。此外，TTimer 不是线程安全的，因为 in 使用了 VCL 的 AllocateHwnd() 函数，该函数不是线程安全的，不应在主线程上下文之外使用。通常，在编写服务应用程序时，您会生成一个工作线程来执行主要逻辑。

如果你需要一个线程安全的定时器，我建议你使用不同的定时器机制，比如WaitForSingleObject()

此外，服务不应包含任何视觉控件，因为它们根本不应与桌面交互。

Answer 2

Could somebody give me an example of service application with threads.

如果您的代码在一个线程中完成所有工作，那么您就快完成了。

只需在服务启动事件中启动您的线程即可。对于调试，运行小（控制台）程序中的线程。

让您的主线程休眠一段时间，而不是计时器。

Answer 3

您显示的 TTimer 代码很好（虽然您的 OnExecute 事件是多余的，但应该完全删除），除了调用 ShowMessage()，你根本不能在服务中使用（TService.Interactive 属性对 Windows Vista+ 没有影响）。如果您必须显示来自服务的弹出消息框（您应该尽量不要这样做），则必须使用指定了 MB_SERVICE_NOTIFICATION 标志的 Win32 API MessageBox()，或者使用 WTSSendMessage() 代替。否则，您必须将任何 UI 委托给服务产生的单独的非服务进程 and/or 根据需要与之通信。

另一方面，您的 TThread 代码完全错误。它应该更像这样：

unit TMS;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.SvcMgr;

type
  TWorkflowThread = class(TThread)
  protected
    procedure Execute; override;
  end;

  TWorkflow = class(TService)
    FDTransaction1: TFDTransaction;
    FDQuery1: TFDQuery;
    procedure ServiceStart(Sender: TService; var Started: Boolean);
    procedure ServiceStop(Sender: TService; var Stopped: Boolean);
    procedure ServiceShutdown(Sender: TService);
  private
    { Private declarations }
    thread: TWorkflowThread;
    procedure InsertInFile;
    procedure InsertInDatabase;
  public
    function GetServiceController: TServiceController; override;
    { Public declarations }
  end;

var
  Workflow: TWorkflow;

implementation

{$R *.dfm}

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

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

procedure TWorkflow.InsertInFile;
const
  FileName = 'D:\Projekti\EMBRACADERO\TMSWorkflow\Win32\Debug\Log.txt';
var
  F : TextFile;
begin
  try
    AssignFile(F, FileName);
    try
      if FileExists(FileName) then
        Append(F)
      else
        Rewrite(F);
      Writeln(F, DateTimeToStr(Now), ' ', DiskFree(0));
      //ShowMessage(DateTimeToStr(Now));
    finallly
      CloseFile(F);
    end;
  except
  end;
end;

procedure TWorkflow.InsertInDatabase;
begin
  try
    FDTransaction1.StartTransaction;
    try
      FDQuery1.Execute;
      FDTransaction1.Commit;
    except
      FDTransaction1.Rollback;
    end;
  except
  end;
end;

procedure TWorkflow.ServiceStart(Sender: TService; var Started: Boolean);
begin
  thread := TWorkflowThread.Create(False);
  Started := True;
end;

procedure TWorkflow.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
  ServiceShutdown(Sender);
  Stopped := True;
end;

procedure TWorkflow.ServiceShutdown(Sender: TService);
begin
  if Assigned(thread) then
  begin
    thread.Terminate;
    while WaitForSingleObject(thread.Handle, WaitHint-100) = WAIT_TIMEOUT do
      ReportStatus;
    FreeAndNil(thread);
  end;
end;

procedure TWorkflowThread.Execute;
begin
  while not Terminated do
  begin
    Workflow.InsertInFile;
    Workflow.InsertInDatabase;
    TThread.Sleep(3000);
  end;
end;

end.

Delphi 中的服务申请

Service application in Delphi

delphi

windows-services