Delphi中的Windows服務與數據庫連接

Question

我想了解一下情況。

我創建了一個Windows服務來完成應用程序的任務管理。

該服務連接到數據庫（Firebird）並調用執行任務管理的組件。

此過程正常，但在Windows 10中，重新啟動計算機后服務不會自動啟動。 在其他版本的Windows中，一切都很完美。 在測試中，我已經確定如果我評論調用任務執行的方法，該服務通常在Windows 10上啟動。

Procedure TDmTaskService.ServiceExecute(Sender: TService);
Begin
  Inherited;

  While Not Terminated Do
  Begin
    //Process;
    Sleep(3000);
    ServiceThread.ProcessRequests(False);
  End;

End;

問題是組件或服務中沒有生成任何異常。

通過分析Windows事件監視器，我發現我的服務發生的錯誤是超時，在這種情況下，服務無法在時間限制內連接到服務管理器。 不再生成異常。

有沒有人有任何關於連接數據庫的Delphi制作的Windows服務？

我的源代碼示例：

**Base class:**

unit UnTaskServiceDmBase;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs;

type
  TDmTaskServicosBase = class(TService)
  private
    { Private declarations }
  public
    function GetServiceController: TServiceController; override;
    { Public declarations }
  end;

var
  DmTaskServiceBase: TDmTaskServicosBase;

implementation

{$R *.DFM}

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

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

end.    

**Service Class:**    

Unit UnTaskServiceDm;

    Interface

    Uses
      Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs,

      UnJBTask,
      UnJBReturnTypes,
      UnJBUtilsFilesLog,
      UnTaskServiceDmConfig,
      UnTaskServiceDmConnection,
      ExtCtrls,
      IniFiles;

    Type
      TDmTaskService = Class(TDmTaskServicosBase)
        Procedure ServiceExecute(Sender: TService);
        Procedure ServiceCreate(Sender: TObject);
        Procedure ServiceStop(Sender: TService; Var Stopped: Boolean);
      Private
        FTaskServiceConfig: TDmTaskServiceConfig;
        FStatus: TResultStatus;
        FDmConnection: TDmTaskServiceConnection;
        FJBTask: TJBTask;
        FLog: TJBUtilsFilesLog;

        Procedure ExecuteTasksSchedule;
        Procedure UpdateServiceInformation;
        Procedure Process;
        Procedure UpdateConnection;
      Public
        Function GetServiceController: TServiceController; Override;
      End;


    Implementation

    {$R *.DFM}

    Procedure ServiceController(CtrlCode: DWord); Stdcall;
    Begin
      DmTaskService.Controller(CtrlCode);
    End;

    Procedure TDmTaskService.UpdateConnection;
    Begin

      Try
        FDmConnection.SqcCon.Connected := False;
        FDmConnection.SqcCon.Connected := True;

        FLog.Adicionar('Conexão com banco restabelecida.');
        FLog.FinalizarLog;
      Except

        On E: Exception Do
        Begin
          FLog.Adicionar('Erro ao restabelecer conexão com o banco de dados.' +
            sLineBreak + sLineBreak + E.Message);
          FLog.FinalizarLog;
        End;

      End;

    End;

    Procedure TDmTaskService.UpdateServiceInformation;
    Begin
      Inherited;

      Try

        Try
          FTaskServiceConfig.Load;

          FLog.Adicionar('Dados registro serviço.');
          FLog.Adicionar('Nome: ' + FTaskServiceConfig.ServiceName);
          FLog.Adicionar('Descrição: ' + FTaskServiceConfig.ServiceDescription);

          If (FTaskServiceConfig.ServiceName <> EmptyStr) And
            (FTaskServiceConfig.ServiceDescription <> EmptyStr) Then
          Begin
            Name := FTaskServiceConfig.ServiceName ;
            DisplayName := FTaskServiceConfig.ServiceDescription;
          End;

          FTaskServiceConfig.Close;

        Except

          On E: Exception Do
          Begin
            FLog.Adicionar('Erro adicionar dados registro serviço.');
            FLog.Adicionar('Erro ocorrido: ' + sLineBreak + sLineBreak + E.Message);
          End;

        End;

      Finally
        FLog.Adicionar('Name: ' + Name);
        FLog.Adicionar('DisplayName: ' + DisplayName);
        FLog.FinalizarLog;
      End;

    End;

    Procedure TDmTaskService.Process;
    Begin

      Try

        If FDmConnection.SqcCon.Connected Then
        Begin

            ExecuteTasksSchedule;

        End
        Else
          UpdateConnection;

      Except

        On E: Exception Do
        Begin

          FLog.Adicionar('Ocorreu um erro ao checar as tarefas.' + sLineBreak +
            'Erro ocorrido: ' + sLineBreak + E.Message);
          FLog.FinalizarLog;

          UpdateConnection;

        End;

      End;

    End;

    Procedure TDmTaskService.ExecutarTarefasAgendadas;
    Begin

      If FJBTask.ExistTaskDelayed Then
      Begin

        Try
          FJBTask.ExecuteTasks;
        Except

          On E: Exception Do
          Begin
            FLog.Adicionar('Ocorreu um erro ao executar as tarefas agendadas.' +
              sLineBreak + 'Erro ocorrido: ' + sLineBreak + E.Message);
            FLog.FinalizarLog;

            UpdateConnection;
          End;

        End;

      End;

    End;

    Function TDmTaskService.GetServiceController: TServiceController;
    Begin
      Result := ServiceController;
    End;

    Procedure TDmTaskService.ServiceCreate(Sender: TObject);
    Begin
      Inherited;

      Try
        FLog := TJBUtilsFilesLog.Create;
        FLog.ArquivoLog := IncludeTrailingPathDelimiter(FLog.LogFolder) + 'TaksService.log';

        FDmConnection := TDmTaskServiceConexao.Create(Self);
        FDmConnection.Log := FLog;

        FJBTask := TJBTarefa.Create(Self);
        FJBTask.SQLConnection := FDmConnection.SqcConexao;

        FTaskServiceConfig := TDmTaskServiceConfig.Create(Self);
        FTaskServiceConfig.SQLConnection := FDmConnection.SqcConexao;

        FStatus := FDmConnection.ConfigurouConexao;

        If FStatus.ResultValue Then
        Begin
          UpdateServiceInformation;
        End
        Else
        Begin
          FLog.Adicionar(FStatus.MessageOut);
          FLog.FinalizarLog;
        End;

      Except

        On E: Exception Do
        Begin
          FLog.Adicionar('Não foi possível iniciar o serviço.' + sLineBreak +
            'Erro ocorrido: ' + sLineBreak + sLineBreak + E.Message);
          FLog.FinalizarLog;
          Abort;
        End;

      End;

    End;

    Procedure TDmTaskService.ServiceExecute(Sender: TService);
    Begin
      Inherited;

      While Not Terminated Do
      Begin
        Process;
        Sleep(3000);
        ServiceThread.ProcessRequests(False);
      End;

    End;

    Procedure TDmTaskService.ServiceStop(Sender: TService; Var Stopped: Boolean);
    Begin
      Inherited;

      If Assigned(FDmConnection) Then
      Begin

        FLog.Adicionar('Finalizando serviço.');
        FLog.Adicionar('Fechando conexão.');
        Try
          FDmConnection.SqcConexao.Close;
        Finally
          FLog.FinalizarLog;
        End;

      End;

    End;

    End.

Answer 1

通過分析Windows事件監視器，我發現我的服務發生的錯誤是超時，在這種情況下，服務無法在時間限制內連接到服務管理器。 不再生成異常。

請勿在TService.OnCreate事件中連接到您的數據庫或執行任何其他冗長的操作。 這種邏輯屬於TService.OnStart事件。 或者更好的是，為它創建一個工作線程，然后在TService.OnStart事件中啟動該線程，並在TService.On(Stop|Shutdown)事件中終止它。

當SCM啟動您的服務進程時，它只等待一小段時間讓新進程調用StartServiceCtrlDispatcher() ，它將進程連接到SCM，以便它可以開始接收服務請求。 在首先完全構造所有TService對象之后， TServiceApplication.Run()調用StartServiceCtrlDispatcher() 。 由於在您的進程嘗試初始化自身時調用OnCreate事件，因此在調用StartServiceCtrlDispatcher()之前，服務構造中的任何延遲都可能導致SCM超時並終止進程。

此外，您應該完全擺脫TService.OnExecute事件處理程序。 您甚至根本不應該使用該事件，並且當OnExecute未分配任何處理程序時，您當前擁有的內容並不比TService在內部執行的操作OnExecute 。

Answer 2

在您的服務代碼中： - 您可以嘗試在Firebird服務上添加依賴項 - 您可以增加WaitHint

如果它仍然不起作用：你可以自動啟動，但“延遲”

Answer 3

我發現它可以解決，但是，我感謝大家的提示，因為及時你會改進我的服務。

解決方案是通過Windows ServicesPipeTimeout注冊表項擴展服務啟動超時。

對於我的情況，它工作得很好。 我將ServicesPipeTimeout的值增加到120000（2分鍾）。 默認情況下，該值為30000（30秒）或更短。

要手動編輯：

1）打開Windows Regedit App; 2）找到並單擊以下注冊表子項： - HKEY_LOCAL_MACHINE \\ SYSTEM \\ CurrentControlSet \\ Control在面板值中，找到ServicesPipeTimeout條目。

** Note **: 
If the ServicesPipeTimeout entry does not exist, you must create it. To do 
this, follow these steps:

- 在“編輯”菜單上，指向“新建”，然后單擊“DWORD值”。 - 鍵入ServicesPipeTimeout，然后按Enter。 3）右鍵單擊“ServicesPipeTimeout”，然后單擊“修改”。 4）單擊“十進制”，鍵入120000，然后單擊“確定”。 ** 120000毫秒= 2分鍾5）重新啟動計算機。

在Delphi中（示例注冊表值）：

Procedure TForm3.JBButton3Click(Sender: TObject);
Const
  CKeyConfigTimeout = 'SYSTEM\CurrentControlSet\Control';
  CValueConfigTimeout = 'ServicesPipeTimeout';

Var
  LReg: TRegistry;

Begin

  LReg := TRegistry.Create;
  Try
    LReg.RootKey := HKEY_LOCAL_MACHINE;
    LReg.OpenKey(CKeyConfigTimeout, False);
    LReg.WriteInteger(CValueConfigTimeout, 120000);
  Finally
    LReg.CloseKey;
    FreeAndNil(LReg);
  End;

End;

注意：帶有注冊表更新代碼的delphi應用程序需要在Windows Vista / Server或Superior版本的管理員模式下運行;