Delphi 中的服务应用程序

Question

我在 Delphi 中的服务应用程序上遇到了困难，但到目前为止还没有取得重大成功。我尝试重新创建这个项目，但它似乎无法正常工作。文件已创建，但日期和时间不会每 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

您显示的

TTimer

代码很好（尽管您的

OnExecute

事件是多余的，应该完全删除），除了 对

ShowMessage()

的调用，您根本不能在服务中使用它（

TService.Interactive 

属性对 Windows Vista+ 没有影响）。如果您必须从服务中显示弹出消息框（您应该尽量不要这样做），则必须使用 Win32 API

MessageBox()

并指定

MB_SERVICE_NOTIFICATION

标志，或者使用

WTSSendMessage()

代替。否则，您必须将任何 UI 委托给服务根据需要生成和/或与之通信的单独的非服务进程。

您的

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.

Answer 2

您的计时器代码将不会执行，因为计时器依赖于

TService

不提供的窗口句柄和消息泵。此外，

TTimer

不是线程安全的，因为使用了 VCL 的

AllocateHwnd()

函数，该函数不是线程安全的，不应在主线程上下文之外使用。一般来说，在编写服务应用程序时，您会生成一个工作线程来执行主要逻辑。

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

WaitForSingleObject()

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

Answer 3

有人可以给我一个带有线程的服务应用程序的示例吗？

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

只需在服务启动事件中启动线程即可。为了进行调试，请在小型（控制台）程序中运行线程。

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