delphi - 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

您显示的 TTimer 代码很好(尽管您的 OnExecute 事件是多余的，应该完全删除)，除了调用ShowMessage()，您根本不能在服务中使用它(TService.Interactive 属性在 Windows Vista+ 上没有效果)。如果您必须从服务中显示弹出消息框(您应该尽量不要这样做)，则必须使用指定了 MB_SERVICE_NOTIFICATION 标志的 Win32 API MessageBox()，或者请改用 WTSSendMessage()。否则，您必须将任何 UI 委托(delegate)给服务根据需要生成和/或与之通信的单独的非服务进程。

另一方面，您的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.