NT服务程序

请先看一个例子：

unit AppService;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs,
  ShellAPI, ExtCtrls; 
{
  TService是一个封装NT服务程序的类，
  它的对象包含对服务的装卸、注册、取消方法。
}
type
  TAppHeartServer = class(TService)
    Timer1: TTimer;
    procedure ServiceStart(Sender: TService; var Started: Boolean);
    procedure ServiceStop(Sender: TService; var Stopped: Boolean);
    procedure ServicePause(Sender: TService; var Paused: Boolean);
    procedure ServiceContinue(Sender: TService; var Continued: Boolean);
    procedure ServiceCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure ServiceDestroy(Sender: TObject);
  private
    SvrName: string;
    SvrPath: string;
    RunLog: Boolean;
  public
    function RunTask: Boolean;
    function GetServiceController: TServiceController; override;
    { Public declarations }
  end;

var
  AppHeartServer: TAppHeartServer;

implementation

{$R *.DFM}

uses
  Tlhelp32;

function CheckTask(ExeFileName: string): Boolean;
const
  PROCESS_TERMINATE = $0001;
var
  ContinueLoop: BOOL;
  FSnapShotHandle: THandle;
  FProcessEntry32: TProcessEntry32;
begin
  Result := False;
  FSnapShotHandle := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
  FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
  ContinueLoop := Process32First(FSnapShotHandle, FProcessEntry32);
  while Integer(ContinueLoop) <> 0 do
  begin
    if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) = UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) = UpperCase(ExeFileName))) then
      Result := True;
    ContinueLoop := Process32Next(FSnapShotHandle, FProcessEntry32);
  end;
end;

function KillTask(ExeFileName: string): Integer;
const
  PROCESS_TERMINATE = $0001;
var
  ContinueLoop: Boolean;
  FSnapShotHandle: THandle;
  FProcessEntry32: TProcessEntry32;
begin
  Result := 0;
  FSnapShotHandle := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
  FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
  ContinueLoop := Process32First(FSnapShotHandle, FProcessEntry32);

  while Integer(ContinueLoop) <> 0 do
  begin
    if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) = UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) = UpperCase(ExeFileName))) then
      Result := Integer(TerminateProcess(OpenProcess(PROCESS_TERMINATE, BOOL(0), FProcessEntry32.th32ProcessID), 0));
    ContinueLoop := Process32Next(FSnapShotHandle, FProcessEntry32);
  end;
  CloseHandle(FSnapShotHandle);
end;

procedure TAppHeartServer.ServiceCreate(Sender: TObject);
begin
  // 依存关系
  if True = CheckTask('MgWayServer.exe') And True = CheckTask('MYSQLD-NT.exe') then
  begin
    OutputDebugString('judgeMent in');
    try
      TDependency(Dependencies.add).name := 'FlcSSODataBase';
      TDependency(Dependencies.add).name := 'MgWayS';
    except
      raise Exception.Create('依存服务未启动, MainServer服务启动失败!');
      exit;
    end;
  end;

  SvrPath := ExtractFilePath(ParamStr(0)) + 'AppHeartServer.exe';
  if not FileExists(SvrPath) then
  begin
    raise Exception.Create
      ('此服务的当前路径下丢失AppHeartServer.exe可执行文件, AppHeartServer服务安装失败!');
    exit;
  end;
  if SvrPath <> '' then
    SvrName := ExtractFileName(SvrPath);

  Timer1.Interval := 500;
  Timer1.Enabled := True;

  OutputDebugString(pchar('SvrPath:  ' + SvrPath));
  OutputDebugString(pchar('SvrName:  ' + SvrName));
end;

procedure TAppHeartServer.ServiceDestroy(Sender: TObject);
begin
  Timer1.Enabled := False;
  Timer1.Destroy;
end;

function TAppHeartServer.RunTask(): Boolean;
Begin
  Result := False;
  ShellExecute(GetDesktopWindow, 'open', pchar(SvrPath), nil, nil, SW_SHOWNORMAL);
  Result := True;
end;

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

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

procedure TAppHeartServer.ServiceContinue(Sender: TService; var Continued: Boolean);
begin
  OutputDebugString(pchar('ServiceContinue*****'));

  if SvrName = '' then
    exit;
  if CheckTask(SvrName) = False then
  begin
    if RunTask = True then
    begin
      Continued := True;
    end;
  end;
  RunLog := True;
end;

procedure TAppHeartServer.ServicePause(Sender: TService; var Paused: Boolean);
begin
  OutputDebugString(pchar('ServicePause*****'));

  if SvrName = '' then
    exit;
  if CheckTask(SvrName) = True then
  begin
    if KillTask(SvrName) <> 0 then
    begin
      Paused := True;
    end;
  end;
  RunLog := False;
end;

procedure TAppHeartServer.ServiceStart(Sender: TService; var Started: Boolean);
begin
  OutputDebugString(pchar('ServiceStart*****'));

  if SvrName = '' then
    exit;
  if CheckTask(SvrName) = False then
  begin
    if RunTask = True then
    begin
      Started := True;
    end;
  end;
  RunLog := True;
end;

procedure TAppHeartServer.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
  OutputDebugString(pchar('ServiceStop*****'));

  if SvrName = '' then
    exit;
  if KillTask(SvrName) <> 0 then
  begin
    Stopped := True;
  end;
  RunLog := False;
end;

procedure TAppHeartServer.Timer1Timer(Sender: TObject);
begin
  if SvrName = '' then
    exit;

  if (RunLog = True) and (CheckTask(SvrName) = False) then
  begin
    if RunTask() = False then
    begin
      Sleep(1000);
    end;
  end;

  if CompareStr(TimeToStr(Time), '0:00:00') = 0 then
  begin
    if CheckTask(SvrName) = True then
    begin
      if KillTask(SvrName) <> 0 then
      begin
        if RunTask() = True then
        begin
          OutputDebugString('AppHeartServer零点重启成功');
          Sleep(1000);
        end;
      end;
    end;
  end;
end;

end.

 

一、服务程序 

        服务程序（ServiceApplication）是一种运行于WinNT的后台程序，每个服务程序（ServiceApplication）中可能包含若干个服务（Service），每个服务就是其中的一个线程（该服务也可以创建多个子线程）。采用服务，应用程序可以获得特殊的权限，而且不会被用户通过Win2000的任务管理器直接结束程序，所以服务常常用来实现一些特殊的目标。
　　通过Win2000控制面板中的服务管理工具，我们可以设置/查看服务的特性：
　　（1）服务名称；（2）显示名称；（3）描述；（4）启动类型；（5）依赖关系；
　　其中，服务名称是标识给服务的。
　　以Win2000的C:\WINNT\System32\services.exe程序为例子，该Exe文件对应一个ServiceApplication，是该服务程序的可见实体；该exe中包含多个服务（Service），例如Alerter，Dhcp（DHCPClient），Messenger等。当我们结束一个服务的时候，该服务所在的ServiceApplication中的其他服务并没有被终止。
　　在Delphi中，Borland的工程师为我们提供了TServiceApplication，TService，TServiceThread等类，封装了大量细节，简化了服务程序的开发。

二、TServiceApplication

　　在Delphi中，类TServiceApplication就对应上述的ServiceApplication。利用Delphi的开发环境，我们新建一个ServiceApplicationProject，同时就创建了一个继承自TService的类。项目文件(ide/project/source view)中的Application对象就是一个TServiceApplication实例。每个TServiceApplication包含若干个TService对象，正好对应上述的服务程序和服务之间的数量关系。

　　通过阅读TServiceApplication和TService类的定义，可以得知，TServiceApplication从TComponent类继承而来，TService从类TDataModule基础而来，Application对象负责各个TService对象的Create和Destroy。跟踪下列代码

　　Application.CreateForm(TService1,Service1);

　　可以发现创建的TService对象的Owner都是Application对象；在VCLFramework中Owner总是负责Destroy各个Component对象（VCL的TComponent类采用了Composite模式），所以TServiceApplication也将Destroy各个TService对象。
　　下面跟踪TServiceApplication.Run的代码，可以发现TServiceApplication首先解析运行参数，实现了服务的Install和Uninstall。然后，初始化一个ServiceStartTable数组，该数组包含了各个service对象的服务名称和运行入口；最后创建一个TServiceStartThread对象，该对象是一个线程对象，从线程调用API：StartServiceCtrlDispatcher来启动ServiceStartTable中指定的若干个服务；而ServiceApplication主线程就不断循环，处理消息，比如接收请求来停止/暂停某个服务。

三、TService

　　TService类继承自类TDataModule，这意味着我们可以加入大量的VCL控件，实现丰富的功能。此外，我们还可以处理OnStart，OnPause，OnStop，OnContinue，OnCreate，OnShutDown等事件。其中需要说明的是：OnStop表示该服务被停止；而OnShutDown表示该ServiceApplication停止运行，这意味着其他服务也被终止了；两者含义是不一样的。

　　前面讲过，ServiceApplication通过调用StartServiceCtrlDispatcher来启动各个服务。StartServiceCtrlDispatcher启动TService的入口，该入口就是TService.Main。TService.Main首先注册该服务，然后调用TService.DoStart。TService.DoStart创建一个内部TServiceThread成员对象，这是一个线程对象；考察TServiceThread.Execute可以得知，当我们处理的TService1.OnExecute，那么TService会把所有的请求委托给该TServiceThread成员对象处理，该对象以默认的方式处理所有的请求。

　　TService.ServiceExecute是TService的主体内容。一个服务要正常运行，除了需要处理它要关注的目标（比如监听某个端口、执行某个任务等）外，还要响应外部命令/请求：比如终止、暂停、恢复该服务。因此可以考虑创建一个专门的线程来完成该任务，而在ServiceExecute中处理外面命令/请求。因此代码如下：
{ Execute until we're told to onstop(即ServiceThread.Terminate) }
while not Terminated do
begin
   ServiceThread.ProcessRequests(False);{ if not ServiceThread.Suspended Let other threads execute }
end;
　　当然，也可以在OnExecute中处理某些任务，如监听某个端口，但是这常常会导致该Service不能及时响应Stop/Pause等请求。当OnExecute执行完了，该服务实际上就完成了任务要结束了（terminate）。

 

每个Tservice对象都有一个线程(ServiceThread)。
属性:
DisplayName
ServiceThread
Terminated
方法:
ReportStatus
事件:

 

线程的状态: 启动(start)、终止(stop)、睡眠(sleep)、挂起 (suspend)、恢复(resume)、等待(wait)和通知(notify)。

 

四、代码演示 

{ 为这个服务添加一个主窗口, 运行后任务栏只显示程序的图标, 双击图标将显示主窗口,上面有一个按钮, 点击该按钮将实现Ctrl + Alt + Del功能. }


program SvrPro;

uses
  SvcMgr,
  SvrMain in 'SvrMain.pas' {ServerMain: TService},
  Unit_FrmMain in 'Unit_FrmMain.pas' {FrmMain};

{$R *.RES}

begin
  if not Application.DelayInitialize or Application.Installing then
    Application.Initialize;
  Application.CreateForm(TServerMain, ServerMain);
  Application.CreateForm(TFrmMain, FrmMain);
  Application.Run;

  {
  选择File|New菜单，在New Items页中选择Service Application。
  这样就在你的工程里加入一个全局变量命名的应用（Application: TServiceApplication = nil）， 它是 TserviceApplication类型。
  每个服务工程自动的调用这个TServiceApplication实例，并不需要直接的对它编程。
  另外自动产生一个TService对象。

  TServiceApplication封装了windows NT Service Application。它提供服务应用的基本行为框架。
  它包含TService对象，每个Tservice封装了一个NT服务。
  服务应用提供服务产生、安装、注册、分发和卸载的方法。
  }

end.

 

unit SvrMain;

interface

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

type
  TServerMain = class(TService)
    procedure ServiceContinue(Sender: TService; var Continued: Boolean);
    procedure ServiceExecute(Sender: TService);
    procedure ServicePause(Sender: TService; var Paused: Boolean);
    procedure ServiceShutdown(Sender: TService);
    procedure ServiceStart(Sender: TService; var Started: Boolean);
    procedure ServiceStop(Sender: TService; var Stopped: Boolean);
  private
    { Private declarations }
  public
    function GetServiceController: TServiceController; override;
    { Public declarations }
  end;

var
  ServerMain: TServerMain;

implementation

{$R *.DFM}

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

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

procedure TServerMain.ServiceContinue(Sender: TService; var Continued: Boolean);
begin
  while not Terminated do
  begin
    Sleep(10);
    ServiceThread.ProcessRequests(False);
  end;
end;

procedure TServerMain.ServiceExecute(Sender: TService);
begin
  while not Terminated do
  begin
    Sleep(10);
    ServiceThread.ProcessRequests(False); // 防止ServiceThread阻塞
  end;
end;

procedure TServerMain.ServicePause(Sender: TService; var Paused: Boolean);
begin
  Paused := True;
end;

procedure TServerMain.ServiceShutdown(Sender: TService);
begin
  gbCanClose := True;
  FrmMain.Free;
  Status := csStopped;
  ReportStatus();
end;

procedure TServerMain.ServiceStart(Sender: TService; var Started: Boolean);
begin
  Started := True;
  SvcMgr.Application.CreateForm(TFrmMain, FrmMain); // 全局变量Application
  gbCanClose := False;
  FrmMain.Hide;
end;

procedure TServerMain.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
  Stopped := True;
  gbCanClose := True;
  FrmMain.Free;
end;

end.

 

 

unit Unit_FrmMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, ShellApi, Graphics, Controls,
  Forms, Dialogs, ExtCtrls, StdCtrls;

const
  WM_TrayIcon = WM_USER + 1234;

type
  TFrmMain = class(TForm)
    Button1: TButton;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FormDestroy(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    IconData: TNotifyIconData;
    procedure AddIconToTray;
    procedure DelIconFromTray;
    procedure TrayIconMessage(var Msg: TMessage); message WM_TrayIcon;
    procedure SysButtonMsg(var Msg: TMessage); message WM_SYSCOMMAND;
  public
    { Public declarations }
  end;

var
  FrmMain: TFrmMain;
  gbCanClose: Boolean; // 全局变量

implementation

{$R *.dfm}

procedure TFrmMain.FormCreate(Sender: TObject);
begin
  FormStyle := fsStayOnTop; // 最前端显示
  SetWindowLong(Application.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW);
  // 窗体图标不显示在任务栏，以进行后边的控制添加图标到任务栏
  // 恢复显示窗体图标用
  {
    SetWindowLong(Application.Handle, GWL_EXSTYLE, GetWindowLong(Application.Handle, GWL_EXSTYLE)   and   not   WS_EX_TOOLWINDOW);
    ShowWindow(Application.Handle, SW_HIDE);
    ShowWindow(Application.Handle, SW_SHOW);
  }
  gbCanClose := False;
  Timer1.Interval := 1000;
  Timer1.Enabled := True;
end;

// 对话框上的"关闭叉“事件，重写为隐藏窗体
procedure TFrmMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  CanClose := gbCanClose;
  if not CanClose then
  begin
    Hide;
  end;
end;

procedure TFrmMain.FormDestroy(Sender: TObject);
begin
  Timer1.Enabled := False;
  DelIconFromTray; // 关闭应用程序的时候要释放掉建立的托盘程序，否则会占用系统资源
end;

{
  TNotifyIconData
  1> cbSize就是你定义的NotifyIcon变量的大小，用SizeOf(TNotifyIconData)可以取得，如果你是一个熟练的C/C++程 序员，你应该不会陌生。在C/C++中，每当要为一个结构体变量分配内存的时候都要：通过   SizeOf(Struct   type)   来获知存放一个这样的结构体变量要多少内存。
  2> Wnd是一个句柄，你希望托盘程序产生的消息有哪个窗体来处理就让Wnd指向那个窗体。
  例如：你准备在任务栏的托盘小图标上单击时窗体是窗体在“显示”和“隐藏”之间切换，则把Wnd指向主窗体。
  3> uID:如果你要创建多个托盘小程序，那么怎么区分它们呢？就是靠这个ID号来区分。
  4> uFlags是一个标志位，它表示当前所创建的托盘程序具有哪些性质：
  NIF_ICON表示当前所设置的图标（即hIcon的值）是有效的
  NIF_MESSAGE表示当前所设置的系统消息（即uCallBackMessage的值）是有效的
  NIF_TIP表示当前所设置的提示条（即szTip的值）是有效的。
  5> uCallBackMessage这是7个部分里面最重要的一个。这里指定一个回调消息，也就是说这里定义一个消息名，当你单击或者右击托盘图标的时候就 会向你在Wnd所指向的窗体发送一个在uCallBackMessage中定义的消息名，然后你在程序中定义一个消息出来函数来处理这个消息。这样就把 Windows关于消息的整套流程都处理好了。
  6> hIcon为托盘图标的句柄，根据这个句柄你就可以增加、修改、删除图标。
  7> szTip就是当你的鼠标放到任务栏托盘的小图标上的时候弹出来的提示信息。
}
procedure TFrmMain.AddIconToTray;
begin
  ZeroMemory(@IconData, SizeOf(TNotifyIconData));
  IconData.cbSize := SizeOf(TNotifyIconData);
  IconData.Wnd := Handle;
  IconData.uID := 1;
  IconData.uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
  IconData.uCallbackMessage := WM_TrayIcon; // 指定一个回调消息
  IconData.hIcon := Application.Icon.Handle;
  IconData.szTip := 'Delphi服务演示程序';
  Shell_NotifyIcon(NIM_ADD, @IconData);
  // NIM_ADD 向托盘区域添加一个图标。此时第二个参数lpdata指向的NOTIFYICONDATA结构体中的hWnd和uID成员用来标示这个图标，以便以后再次使用Shell_NotifyIcon对此图标操作。
end;

procedure TFrmMain.DelIconFromTray;
begin
  Shell_NotifyIcon(NIM_DELETE, @IconData);
end;

procedure TFrmMain.SysButtonMsg(var Msg: TMessage);
begin
  if (Msg.wParam = SC_CLOSE) or (Msg.wParam = SC_MINIMIZE) then
    Hide
  else
    inherited; // 执行默认动作
end;

procedure TFrmMain.TrayIconMessage(var Msg: TMessage);
begin
  if (Msg.LParam = WM_LBUTTONDBLCLK) then
    Show();
end;

procedure TFrmMain.Timer1Timer(Sender: TObject);
begin
  AddIconToTray;
end;

procedure SendHokKey; stdcall;
var
  HDesk_WL: HDESK;
begin
  {
    当键盘或鼠标等硬件消息出现后，如果具有 JournalRecord权限, 就可以将这些硬件动作保存以便未来重新播放这些动作。
    而JOURNALPLAYBACK即时具有回放已经记录的硬件动作， 但是回放时需要确保没有硬件信息重新进入记录队列，所以会使键盘和鼠标等失效。
  }
  HDesk_WL := OpenDesktop('Winlogon', 0, False, DESKTOP_JOURNALPLAYBACK);
  if (HDesk_WL <> 0) then
  begin
    if (SetThreadDesktop(HDesk_WL) = True) then // 设置当前Thread工作所在的Desktop
    begin
      PostMessage(HWND_BROADCAST, WM_HOTKEY, 0, MAKELONG(MOD_ALT or MOD_CONTROL,  VK_DELETE));
    end;
  end;
end;

procedure TFrmMain.Button1Click(Sender: TObject);
var
  dwThreadID: DWord;
begin
  CloseHandle(CreateThread(nil, 0, @SendHokKey, nil, 0, dwThreadID));
end;

end.