Пример службы на Delphi (WinAPI)

На нем тоже кодим под винду =)
Аватара пользователя
Scamper
Постоялец
Сообщения: 67
Зарегистрирован: 17 дек 2014, 18:09
Откуда: Екатеринбург
Контактная информация:

Пример службы на Delphi (WinAPI)

Сообщение Scamper » 21 дек 2014, 13:42

Пример службы на Delphi (WinAPI)

Проверено и работает Diffit ))
Автор статьи: romix

Чтобы создать службу на Delphi, достаточно нажать F1, набрать TService и прочитать раздел using tservice. Но можно написать службу и на более низком уровне WinAPI, чему и посвящена статья.

Поместить в файл с расширением dpr, например, srv1.dpr.
Установка службы - srv1.exe /Install
Удаление службы - srv1.exe /Delete
Имя службы - "Sample_Srv"
Выполняемое действие - периодический звуковой сигнал beep()

"Написание сервисов Windows NT на WinAPI"

Служба будет периодически выдавать окно Предупреждения.
Чтобы показывалось это окно сообщения, установите
Мой компьютер-Правый клик-Управление-Службы и приложения-Службы (англ. Services)
В списке выберите свою службу (в данном случае Sample_Srv).
Свойства - закладка Вход в систему - установить флажок
"Разрешить взаимодействие с рабочим столом" (англ. "Interact with desktop").

Code

Код: Выделить всё

program Project1;

uses
  Windows, WinSvc, SysUtils;

const c_ServiceName = 'Sample_Srv';

var DispatchTable : array [0..1] of _SERVICE_TABLE_ENTRYA;
var sst : SERVICE_STATUS;
var sstHandle : SERVICE_STATUS_HANDLE;

///////////////////////////////////////////////////////////////////////
procedure SetServiceStatus1;
begin
   if not SetServiceStatus(sstHandle,sst) then
   RaiseLastOSError;
end;
///////////////////////////////////////////////////////////////////////
procedure ServiceCtrlHandler(Opcode : Cardinal);stdcall;
begin
  case Opcode of

   SERVICE_CONTROL_STOP:
    begin
     sst.dwWin32ExitCode:=0;
     sst.dwCurrentState := SERVICE_STOPPED;
     sst.dwCheckPoint   :=0;
     sst.dwWaitHint     :=0;
     SetServiceStatus1;
     exit;
    end;

   SERVICE_CONTROL_INTERROGATE : ;
  end;

  SetServiceStatus1;
end;

///////////////////////////////////////////////////////////////////////
procedure ServiceProc(argc : DWORD;var argv : array of PChar);stdcall;
begin
   sst.dwServiceType      := SERVICE_WIN32;
   sst.dwCurrentState     := SERVICE_START_PENDING;
   sst.dwControlsAccepted := SERVICE_ACCEPT_STOP;
//    or SERVICE_ACCEPT_PAUSE_CONTINUE;
   sst.dwWin32ExitCode           := 0;
   sst.dwServiceSpecificExitCode := 0;
   sst.dwCheckPoint              := 0;
   sst.dwWaitHint                := 0;

   sstHandle :=
            RegisterServiceCtrlHandler(c_ServiceName,@ServiceCtrlHandler);

   if sstHandle = 0 then RaiseLastOSError;

    sst.dwCurrentState :=SERVICE_RUNNING;
    sst.dwCheckPoint   :=0;
    sst.dwWaitHint     :=0;

    SetServiceStatus1;

   //ОСНОВНОЙ КОД ПРОГРАММЫ 
   repeat
    sleep(3000);
    beep();
    MessageBox(0, 'Проверка службы', 'sample_srv', 0);
    //Чтобы показывалось окно сообщения, установите 
    //Мой компьютер-Правый клик-Управление-Службы и приложения-Службы (англ. Services) 
    //В списке выберите свою службу. 
    //Свойства - закладка Вход в систему - установить флажок 
    //"Разрешить взаимодействие с рабочим столом" (англ. "Interact with desktop"). 
   until sst.dwCurrentState = SERVICE_STOPPED;
end;

///////////////////////////////////////////////////////////////////////

var schService, schSCManager: SC_HANDLE;
var binExe: pchar;
begin

  if ParamStr(1)='/Install' then begin
    binExe:=pchar(ParamStr(0));

  ///////////////////////////// Установка службы

     schSCManager := OpenSCManager(
     nil,                    // local machine
     nil,                    // ServicesActive database
     SC_MANAGER_ALL_ACCESS);  // full access rights

     if schSCManager=0 then RaiseLastOSError;

     schService := CreateService(
         schSCManager,              // SCManager database
         c_ServiceName,               // name of service
         c_ServiceName,           // service name to display
         SERVICE_ALL_ACCESS,        // desired access
         SERVICE_WIN32_OWN_PROCESS, // service type
         SERVICE_DEMAND_START,      // start type
         SERVICE_ERROR_NORMAL,      // error control type
         binExe,        // service's binary
         nil,                      // no load ordering group
         nil,                      // no tag identifier
         nil,                      // no dependencies
         nil,                      // LocalSystem account
         nil);                     // no password

      if schService=0 then
        RaiseLastOSError;

      if not CloseServiceHandle(schService) then
        RaiseLastOSError;

        exit;

  ///////////////////////////// Удаление службы

    end else if ParamStr(1)='/Delete' then begin

     schSCManager := OpenSCManager(
     nil,                    // local machine
     nil,                    // ServicesActive database
     SC_MANAGER_ALL_ACCESS);  // full access rights

     if schSCManager=0 then RaiseLastOSError;

      schService := OpenService(
         schSCManager,       // SCManager database
         c_ServiceName,       // name of service
         SERVICE_ALL_ACCESS);            // only need DELETE access

     if schService = 0 then
       RaiseLastOSError;

     if not DeleteService(schService) then
       RaiseLastOSError;

     if not CloseServiceHandle(schService) then
       RaiseLastOSError;
     exit;

end;
  ///////////////////////////// Запуск службы
  DispatchTable[0].lpServiceName:=c_ServiceName;
  DispatchTable[0].lpServiceProc:=@ServiceProc;

  DispatchTable[1].lpServiceName:=nil;
  DispatchTable[1].lpServiceProc:=nil;

  if not StartServiceCtrlDispatcher(DispatchTable[0]) then
    RaiseLastOSError;

end.



Автор статьи: romix
Последняя редакция №5 от 08.11.07
Утянуто с http://kb.mista.ru/article.php?id=580

Вернуться в «Pascal & Delphi»

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и 1 гость

cron