Как писать сервисы.

Если Вы воспользуетесь мастером создания сервиса в Delphi, то он даст Вам минимальный код, который годится разве что только для самого начала работы по созданию заготовки пустого ничего не делающего сервиса. К тому же сервис довольно трудно отлаживать. А в операционных системах Windows 9X невозможно использовать вовсе. Поэтому, обычно, сервис делают одновременно обычным приложением с возможностью регистрации и запуска как сервис. Т.е. если операционная система Windows 9X, то запускаем его в автозагрузке, если Windows NT, XP и выше, то регистрируем в сервисах. Если сервис нуждается в настройках или показе текущего состояния, то лучше всего, чтобы он отображал свою иконку в панели задач, как это делают, например, часы, с возможностью управлять им через всплывающее меню. Вот такой сервис мы с Вами сейчас и создадим.

Итак, выполним пункт меню File|New|Other… В списке категорий выберите Delphi Projects и дважды щелкните по иконке Service Applications.

Сохраните полученные модули на диск. Я сохранил сервис как Main.pas, а проект – MyService.pas. Переименуйте сервис в MyService. Затем, добавьте к проекту окно. Это будет окно, показывающее состояние сервера и информацию о программе. Сохраните модуль под именем AboutForm. Так как мы будем запускать наш сервис еще и в режиме простой программы, то нам как-то нужно различать эти два режима. Для этого можно завести глобальную переменную в модуле AboutForm. Я назвал её FromService: boolean. Если запускается сервис, то она равна true, если как программа – false. Вот модуль сервиса:

unit Main;

 interface

 uses

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

  Menus;

 type

  TMyService = class(TService)

    procedure ServiceStop(Sender: TService; var Stopped: Boolean);

    procedure ServiceStart(Sender: TService; var Started: Boolean);

  private

  public

    function GetServiceController: TServiceController; override;

    { Public declarations }

  end;

 var

  MyService: TMyService;

 implementation

 uses AboutForm;

 {$R *.DFM}

 procedure ServiceController(CtrlCode: DWord); stdcall;

begin

  MyService.Controller(CtrlCode);

end;

 function TMyService.GetServiceController: TServiceController;

begin

  Result:=ServiceController;

end;

 procedure TMyService.ServiceStart(Sender: TService; var Started: Boolean);

begin

 Started:=True;

end;

 procedure TMyService.ServiceStop(Sender: TService; var Stopped: Boolean);

begin

 Stopped:=True;

end;

 end.

 Как видите, он практически пустой. Здесь есть только два обработчика на старт и останов сервиса. Вот код окна About:

unit AboutForm;

 interface

 uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

  Dialogs, Menus, ShellApi, Buttons, StdCtrls;

 const WM_MIDASICON = WM_USER + 1;

 type

  TfAbout = class(TForm)

    PopupMenu: TPopupMenu;

    miClose: TMenuItem;

    N1: TMenuItem;

    Config1: TMenuItem;

    miProperties: TMenuItem;

    SpeedButton1: TSpeedButton;

    Label8: TLabel;

    Label9: TLabel;

    Label11: TLabel;

    Label7: TLabel;

    Label6: TLabel;

    procedure Config1Click(Sender: TObject);

    procedure Label7Click(Sender: TObject);

    procedure Label6Click(Sender: TObject);

    procedure SpeedButton1Click(Sender: TObject);

    procedure FormClose(Sender: TObject; var Action: TCloseAction);

    procedure FormDestroy(Sender: TObject);

    procedure FormCreate(Sender: TObject);

    procedure miPropertiesClick(Sender: TObject);

    procedure miCloseClick(Sender: TObject);

  private

    FNT351: Boolean;

    FIconData: TNotifyIconData;

    FClosing: boolean;

    procedure AddIcon;

    procedure DeleteIcon;

    procedure WMMIDASIcon(var Message: TMessage); message WM_MIDASICON;

  protected

  public

  end;

 var

  fAbout: TfAbout;

  FromService: boolean;

 implementation

 {$R *.dfm}

 uses Main;

Иконку можно добавить только начиная с Windows 95 или Windows NT4 (как известно, у неё рабочий стол от Windows 95). Поэтому, сначала нужно проверить версию Windows, и если она выше NT 3.51, то можно добавлять. Добавляется иконка вызовом API оболочки - Shell_NotifyIcon. Для этого просто заполняется структура TnotifyIconData и делается соответствующий вызов. Как видите, саму иконку можно взять из окна About. Это хорошо, т.к. тогда можно сделать иконку 16Х16, а не 32Х32. Такая иконка будет лучше смотреться в панели задач. uCallbackMessage будет посылаться оболочкой всякий раз, когда там происходят некоторые события с мышью.

procedure TfAbout.AddIcon;

begin

 if not FNT351 then

  begin

   with FIconData do

    begin

      cbSize := SizeOf(FIconData);

      Wnd:=Handle;

      uID:=$DEDB;

      uFlags:=NIF_MESSAGE or NIF_ICON or NIF_TIP;

      hIcon:=Icon.Handle;

      uCallbackMessage:=WM_MIDASICON;

      StrCopy(szTip, PChar('My Service'));

    end;

    Shell_NotifyIcon(NIM_Add, @FIconData);

  end;

end;

Здесь мы просто просим оболочку удалить иконку из панели задач.

procedure TfAbout.DeleteIcon;

begin

 if not FNT351 then

   Shell_NotifyIcon(NIM_DELETE, @FIconData);

end;

Метод WMMIDASIcon объявлен как обработчик события WM_MIDASICON. Здесь проверяется какое именно событие произошло. Если двойной клик по иконке, то показывается окно About, если клик правой кнопкой мыши, то показывается всплывающее меню. Это меню можно поставить прямо на окно About. Там три пункта: Close, разделитель, Configuration, About. К нему мы еще вернемся позже.

procedure TfAbout.WMMIDASIcon(var Message: TMessage);

var pt: TPoint;

begin

 case Message.LParam of

  WM_RBUTTONUP: begin

                 if not Visible then

                  begin

                   SetForegroundWindow(Handle);

                   GetCursorPos(pt);

                   PopupMenu.Popup(pt.x, pt.y);

                  end

                 else

                  SetForegroundWindow(Handle);

                end;

   WM_LBUTTONDBLCLK: if Visible then

                      SetForegroundWindow(Handle)

                     else

                      miPropertiesClick(nil);

  end;

end;

При создании окна проверяется версия Windows, затем, если программа запущена как сервис, то делается невидимым пункт меню Close и разделитель. Это сделано специально, чтобы останавливать сервис можно было только в штатном режиме из апплета управления компьютером. Далее, добавляется иконка.

procedure TfAbout.FormCreate(Sender: TObject);

begin

 FNT351 := (Win32MajorVersion <= 3) and (Win32Platform = VER_PLATFORM_WIN32_NT);

 if FromService then

  begin

   miClose.Visible:=false;

   N1.Visible:=false;

  end;

 AddIcon;

 FClosing:=false;

end;

При уничтожении окна иконка удаляется.

procedure TfAbout.FormDestroy(Sender: TObject);

begin

 DeleteIcon;

end;

На всякий случай, если запушено как приложение, то закрытие окна не должно закрывать программу, но если нажать пункт меню Close, то программа должна закрываться. Т.к. мы показываем форму модально, то так оно и будет, но лучше оставить этот код, чтобы быть полностью уверенным.

procedure TfAbout.FormClose(Sender: TObject; var Action: TCloseAction);

begin

 if FClosing then

  Action:=caFree

 else

  Action:=caHide;

end;

На форме About есть кнопка для вызова справки. Т.к. Application для сервиса не имеет методов вызова файла помощи, то пришлось пользоваться API. Здесь ID_CONT определен в файле помощи пункт, а MYSERVER.HLP – имя файла помощи.

procedure TfAbout.SpeedButton1Click(Sender: TObject);

var Command: array[0..255] of Char;

begin

 StrLFmt(Command, SizeOf(Command) - 1, 'JumpID("","%s")', ['ID_CONT']);

 WinHelp(Handle, PChar(ExtractFilePath(ParamStr(0))+'MYSERVER.HLP'), HELP_CONTENTS, Longint(@Command));

end;

На форме стоит две метки с надписью Support и WWW.MYSERVER.RU для перехода на сайт разработчика.

 procedure TfAbout.Label6Click(Sender: TObject);

begin

 ShellExecute(Forms.Application.Handle, 'open', 'mailto:support@myserver.ru?subject=MyServer :   bugs!!!', '', '', SW_SHOW);

end;

 procedure TfAbout.Label7Click(Sender: TObject);

begin

 ShellExecute(Forms.Application.Handle,'open','http://www.myserver.ru','','',SW_SHOW);

end;

Пункт меню Close. Когда запушено приложение, то уничтожение окна About закрывает программу, т.к. оно является главным окном.

procedure TfAbout.miCloseClick(Sender: TObject);

begin

 FClosing:=true;

 Close;

end;

Пункт меню About – просто показывает форму, т.е. саму себя.

procedure TfAbout.miPropertiesClick(Sender: TObject);

begin

 ShowModal;

 DeleteIcon;

 AddIcon;

end;

Пункт меню Configuration. Здесь один из вариантов решения проблемы. Часто для управления настройками сервисов используют апплеты в панели управления. Для этого достаточно написать свою cpl. Но, не хотелось бы повторять весь этот код в сервере. Как известно, cpl – это обычная DLL, поэтому нам ничего не мешает экспортировать какой-нибудь метод из нее и загрузить её динамически…

procedure TfAbout.Config1Click(Sender: TObject);

Type TGetDesignerInterface = procedure; SafeCall;

var GetFunc: TGetDesignerInterface;

    DllHandle: THandle;

const

    DllName = 'MySrvCnf.cpl';

    FuncName = 'EditConfiguration';

begin

 DllHandle:=LoadLibrary(PChar(DllName));

 if DllHandle < 32 then

  raise Exception.Create('Not found "'+DllName+'" !');

  GetFunc:=GetProcAddress(DllHandle, PChar(FuncName));

  if not Assigned(GetFunc) then

   begin

    FreeLibrary(DllHandle);

    raise Exception.Create('Not fount function "'+FuncName+'"');

   end;

  try

   GetFunc;

  finally

   FreeLibrary(DllHandle);

  end;  

end;

 end.

 Наконец, код проекта сервиса:

program MyServer;

Обратите внимание, что в uses указан модуль Forms, который не включается автоматически в проект. Он нам понадобится для запуска нашего сервера как приложения.

 uses

  SvcMgr,

  Forms,

  SysUtils,

  Windows,

  Types,

  WinSvc,

  Main in 'Main.pas' {MyServer: TService},

  AboutForm in 'AboutForm.pas' {fAbout};

 {$R *.RES}

 Проверка командной строки на предмет указаний инсталлировать или удалить сервис.

function Installing: Boolean;

begin

 Result:=FindCmdLineSwitch('INSTALL',['-','\','/'], True) or

         FindCmdLineSwitch('UNINSTALL',['-','\','/'], True);

end;

 Функция проверяет, что приложение запущено как сервис. Этот код просто взят из модуля ScktSrvr.dpr. Кстати, если разобраться в этом проекте, то Вы сможете писать сервисы даже на Delphi 2, 3.

 function StartService: Boolean;

var Mgr, Svc: Integer;

    UserName, ServiceStartName: string;

    Config: Pointer;

    Size: DWORD;

begin

 Result:=False;

 Mgr:=OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);

 if Mgr <> 0 then

  begin

   Svc:=OpenService(Mgr, PChar('MyService'), SERVICE_ALL_ACCESS);

   Result:=Svc <> 0;

   if Result then

    begin

     QueryServiceConfig(Svc, nil, 0, Size);

     Config:=AllocMem(Size);

     try

      QueryServiceConfig(Svc, Config, Size, Size);

      ServiceStartName:=PQueryServiceConfig(Config)^.lpServiceStartName;

      if CompareText(ServiceStartName, 'LocalSystem') = 0 then

       ServiceStartName:='SYSTEM';

     finally

      Dispose(Config);

     end;

     CloseServiceHandle(Svc);

    end;

   CloseServiceHandle(Mgr);

  end;

 if Result then

  begin

   Size:=256;

   SetLength(UserName, Size);

   GetUserName(PChar(UserName), Size);

   SetLength(UserName, StrLen(PChar(UserName)));

   Result:=CompareText(UserName, ServiceStartName) = 0;

  end;

end;

Если приложение запускается как сервис, или если его хотят зарегистрировать как сервис, то мы идем по пути как в проекте, созданном Delphi по умолчанию. Единственное, что лучше явно указывать, какой именно Application мы используем: в SvcMrg – это сервис, а в Forms – это простое приложение. Если же запуск идет как простое приложение, указываем, что не нужно показывать главную форму, делаем форму About основной (первая созданная), создаем форму сервиса. Важно, что сервис – это TdataModule. И когда мы его так создадим из Tapplication, то сервис не будет запущен. Это и хорошо – у нас будет просто подходящий модуль данных J

begin

 if Installing or StartService then

  begin

   SvcMgr.Application.Initialize;

   AboutForm.FromService:=true;

   SvcMgr.Application.CreateForm(TfAbout, fAbout);

   SvcMgr.Application.CreateForm(TMyService, MyService);

   SvcMgr.Application.Run;

  end

 else

  begin

   Forms.Application.ShowMainForm:=False;

   Forms.Application.Initialize;

   AboutForm.FromService:=false;

   Forms.Application.CreateForm(TfAbout, fAbout);

   Forms.Application.CreateForm(TMyService, MyService);

   Forms.Application.Run;

  end;

end.

Уже можно запустить и покликать по меню, закрыть, зарегистрировать и запустить как сервис – все работает. Но, наш сервис пуст и ничего не делает. Что он должен делать – Вам решать.

И последнее, зарегистрировать сервис можно командой MyServer /INSTALL, а удалить регистрацию – MyServer /UNINSTALL.

Успехов в разработке своих сервисов!