Форум программистов [Powered by Invision Power Board]

Код

program ServiceTest;

{$DEFINE SERVICE_DEBUG}

uses
  Windows,SysUtils,WinSvc,QDialogs;

const
  InfoStr = 'Use:'#13#10'%s [ -install | -uninstall ]';
  ServiceFileName = 'ServiceTest.exe';
  Name = 'SvcTest';
  DisplayName = 'Test Service';
  Context = 1;

type
  LPHANDLER_FUNCTION_EX = function (dwControl, dwEventType: DWORD;
    lpEventData, lpContext: Pointer): DWORD; stdcall;
  THandlerFunctionEx = LPHANDLER_FUNCTION_EX;

  function RegisterServiceCtrlHandlerEx(lpServiceName: LPCWSTR;
    lpHandlerProc: LPHANDLER_FUNCTION_EX; lpContext: Pointer):
    SERVICE_STATUS_HANDLE; stdcall; external 'advapi32.dll' name 'RegisterServiceCtrlHandlerExW';

var
  ServicesTable: packed array [0..1] of TServiceTableEntry;
  StatusHandle: SERVICE_STATUS_HANDLE = 0;
  Status: TServiceStatus;

{$R *.res}

// ** Служебные процедуры и функции ********************************************

// Вывод информации (при работе сервиса не применяется)
procedure ShowMsg(Msg: string; Flags: integer = -1);
begin
  if Flags < 0 then Flags := MB_ICONSTOP;
  MessageBox(0, PChar(Msg), ServiceFileName, MB_OK or MB_TASKMODAL or MB_TOPMOST or Flags)
end;

// Инсталяция сервисов в SCM
function Install: Boolean;
const
  StartType =
{$IFDEF SERVICE_DEBUG}
    SERVICE_DEMAND_START;
{$ELSE}
    SERVICE_AUTO_START;
{$ENDIF}
var
  SCManager, Service: SC_HANDLE;
begin
  SCManager := OpenSCManager(nil, nil, SC_MANAGER_CREATE_SERVICE);
  if SCManager <> 0 then
  try
    // инсталируем сервис
    Service := CreateService(SCManager, Name, DisplayName, SERVICE_ALL_ACCESS,
      SERVICE_WIN32_SHARE_PROCESS or SERVICE_INTERACTIVE_PROCESS, StartType, SERVICE_ERROR_NORMAL,
      PChar('"' + ParamStr(0) + '" -service'), nil, nil, nil, nil, nil);
    if Service <> 0 then
    try
      Result := ChangeServiceConfig(Service, SERVICE_NO_CHANGE, SERVICE_NO_CHANGE, SERVICE_NO_CHANGE, nil, nil,
        nil, nil, nil, nil, nil);
    finally
      CloseServiceHandle(Service);
    end
    else
      Result := GetLastError = ERROR_SERVICE_EXISTS;
  finally
    CloseServiceHandle(SCManager);
  end
  else
    Result := False;
end;

// деинсталяция сервиса в SCM
function Uninstall: Boolean;
var
  SCManager, Service: SC_HANDLE;
begin
  SCManager := OpenSCManager(nil, nil, SC_MANAGER_CONNECT);
  if SCManager <> 0 then
  try
    // Удаляем сервис
    Service := OpenService(SCManager, Name, _DELETE);
    if Service <> 0 then
    try
      Result := DeleteService(Service);
    finally
      CloseServiceHandle(Service);
    end
    else
      Result := GetLastError = ERROR_SERVICE_DOES_NOT_EXIST;
  finally
    CloseServiceHandle(SCManager);
  end
  else
    Result := False;
end;

// *** Непосредственно работа сервиса *****************************************

// Инициализация сервиса
function SvcInitialize: Boolean;
begin
  with Status do
  begin
    dwServiceType := SERVICE_WIN32_SHARE_PROCESS;
    dwCurrentState := SERVICE_START_PENDING;
    dwControlsAccepted := SERVICE_ACCEPT_STOP or SERVICE_ACCEPT_SHUTDOWN;
    dwWin32ExitCode := NO_ERROR;
    dwServiceSpecificExitCode := 0;
    dwCheckPoint := 1;
    dwWaitHint := 5000
  end;
  Result := SetServiceStatus(StatusHandle, Status);
end;

// Оповещение SCM что сервис работает
function SvcNotifyIsRunning: Boolean;
begin
  with Status do
  begin
    dwCurrentState := SERVICE_RUNNING;
    dwWin32ExitCode := NO_ERROR;
    dwCheckPoint := 0;
    dwWaitHint := 0
  end;
  Result := SetServiceStatus(StatusHandle, Status);
end;

// Завершение работы первого сервиса
procedure SvcStop(Code: DWORD = NO_ERROR);
begin
  with Status do
  begin
    dwCurrentState := SERVICE_STOPPED;
    dwWin32ExitCode := Code;
  end;
  SetServiceStatus(StatusHandle, Status); // Результатом True - проверял
end;

// Через эту функцию с нашими сервисами общается SCM
function ServicesCtrlHandler(dwControl, dwEventType: DWORD;
  lpEventData, lpContext: Pointer): DWORD; stdcall;
begin
  Result := 1;
  if DWORD(lpContext^)=Context then
    begin
      case dwControl of
        SERVICE_CONTROL_STOP, SERVICE_CONTROL_SHUTDOWN:
          SvcStop;
        SERVICE_CONTROL_INTERROGATE:
          SvcNotifyIsRunning;
      end;
    end;
end;

// Главная процедура сервиса
procedure SvcMainProc(ArgCount: DWORD; var Args: array of PChar); stdcall;
var
  SvcContext: DWORD;
begin
  SvcContext := Context;
  StatusHandle := RegisterServiceCtrlHandlerEx(Name,
    @ServicesCtrlHandler, @SvcContext);
  if (StatusHandle <> 0) and SvcInitialize and SvcNotifyIsRunning then
    while Status.dwCurrentState <> SERVICE_STOP do
    try
      // Собственно работа сервиса
      ShowMsg('Aaaaaaaaaaaaa', MB_ICONINFORMATION);
      Sleep(10000);
    except
      // Обработка ошибок сервиса
    end;
  ExitThread(0);
end;

// Main
begin
  if ParamCount > 0 then
  begin
    // Инсталяция
    if AnsiUpperCase(ParamStr(1)) = '-INSTALL' then
    begin
      if not Install then ShowMsg(SysErrorMessage(GetLastError));
      Exit;
    end;
    // Деинсталяция
    if AnsiUpperCase(ParamStr(1)) = '-UNINSTALL' then
    begin
      if not Uninstall then ShowMsg(SysErrorMessage(GetLastError));
      Exit;
    end;
    // Работа сервиса
    if AnsiUpperCase(ParamStr(1)) = '-SERVICE' then
    begin
      ServicesTable[0].lpServiceName := Name;
      ServicesTable[0].lpServiceProc := @SvcMainProc;
      ServicesTable[1].lpServiceName := nil;
      ServicesTable[1].lpServiceProc := nil;
      // Запускаем сервис, дальше работа идет в его главной процедуры
      if not StartServiceCtrlDispatcher(ServicesTable[0]) and
        (GetLastError <> ERROR_SERVICE_ALREADY_RUNNING) then
          ShowMsg(SysErrorMessage(GetLastError));
    end
    else
      ShowMsg(Format(InfoStr, [ServiceFileName]), MB_ICONINFORMATION);
  end
  else
    ShowMsg(Format(InfoStr, [ServiceFileName]), MB_ICONINFORMATION);
end.