delphi创建具有托盘的服务程序（service）

Windows 2000/XP和2003等支持一种叫做"服务程序"的东西.程序作为服务启动有以下几个好处:

    (1)不用登陆进系统即可运行.
    (2)具有SYSTEM特权.所以你在进程管理器里面是无法结束它的.

    笔者在2003年为一公司开发机顶盒项目的时候,曾经写过课件上传和媒体服务,下面就介绍一下如何用Delphi7创建一个Service程序.
    运行Delphi7,选择菜单File-->New-->Other--->Service Application.将生成一个服务程序的框架.将工程保存为ServiceDemo.dpr和Unit_Main.pas,然后回到主框架.我们注意到,Service有几个属性.其中以下几个是我们比较常用的:

    (1)DisplayName:服务的显示名称
    (2)Name:服务名称.

    我们在这里将DisplayName的值改为"Delphi服务演示程序",Name改为"DelphiService".编译这个项目,将得到ServiceDemo.exe.这已经是一个服务程序了!进入CMD模式,切换致工程所在目录,运行命令"ServiceDemo.exe /install",将提示服务安装成功!然后"net start DelphiService"将启动这个服务.进入控制面版-->管理工具-->服务,将显示这个服务和当前状态.不过这个服务现在什么也干不了,因为我们还没有写代码:)先"net stop DelphiService"停止再"ServiceDemo.exe /uninstall"删除这个服务.回到Delphi7的IDE.

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

    实际上,服务程序莫认是工作于Winlogon桌面的,可以打开控制面板,查看我们刚才那个服务的属性-->登陆,其中"允许服务与桌面交互"是不打钩的.怎么办?呵呵,回到IDE,注意那个布尔属性:Interactive,当这个属性为True的时候,该服务程序就可以与桌面交互了.

File-->New-->Form为服务添加窗口FrmMain,单元保存为Unit_FrmMain,并且把这个窗口设置为手工创建.完成后的代码如下:

unit Unit_Main;

interface

uses

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

type

TDelphiService = 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

DelphiService: TDelphiService;

FrmMain: TFrmMain;

implementation

{$R *.DFM}

procedure ServiceController(CtrlCode: DWord); stdcall;

begin

DelphiService.Controller(CtrlCode);

end;

function TDelphiService.GetServiceController: TServiceController;

begin

Result := ServiceController;

end;

procedure TDelphiService.ServiceContinue(Sender: TService;

var Continued: Boolean);

begin

while not Terminated do

begin

Sleep(10);

ServiceThread.ProcessRequests(False);

end;

procedure TDelphiService.ServiceExecute(Sender: TService);

begin

while not Terminated do

begin

Sleep(10);

ServiceThread.ProcessRequests(False);

end;

procedure TDelphiService.ServicePause(Sender: TService;

var Paused: Boolean);

begin

Paused := True;

end;

procedure TDelphiService.ServiceShutdown(Sender: TService);

begin

gbCanClose := true;

FrmMain.Free;

Status := csStopped;

ReportStatus();

end;

procedure TDelphiService.ServiceStart(Sender: TService;

var Started: Boolean);

begin

Started := True;

Svcmgr.Application.CreateForm(TFrmMain, FrmMain);

gbCanClose := False;

FrmMain.Hide;

end;

procedure TDelphiService.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)

Timer1: TTimer;

Button1: TButton;

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); {不在任务栏显示}

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;

procedure TFrmMain.FormDestroy(Sender: TObject);

begin

Timer1.Enabled := False;

DelIconFromTray;

end;

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);

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

HDesk_WL := OpenDesktop ('Winlogon', 0, False, DESKTOP_JOURNALPLAYBACK);

if (HDesk_WL <> 0) then

if (SetThreadDesktop (HDesk_WL) = True) then

PostMessage(HWND_BROADCAST, WM_HOTKEY, 0, MAKELONG (MOD_ALT or MOD_CONTROL, VK_DELETE));

end;

procedure TFrmMain.Button1Click(Sender: TObject);

var

dwThreadID : DWORD;

begin

CreateThread(nil, 0, @SendHokKey, nil, 0, dwThreadID);

end;

end.

program ServiceDemo;

uses

SvcMgr,

Unit_Main in 'Unit_Main.pas' {DelphiService: TService},

Unit_frmMain in 'Unit_frmMain.pas' {frmMain};

{$R *.RES}

begin

Application.Initialize;

Application.CreateForm(TDelphiService, DelphiService);

Application.Run;

end.

窗体代码如下:

object DelphiService: TDelphiService

OldCreateOrder = False

DisplayName = 'Delphi服务演示程序'

Interactive = True

OnContinue = ServiceContinue

OnExecute = ServiceExecute

OnPause = ServicePause

OnShutdown = ServiceShutdown

OnStart = ServiceStart

OnStop = ServiceStop

Left = 261

Top = 177

Height = 150

Width = 215

end

object frmMain: TfrmMain

Left = 192

Top = 107

Width = 696

Height = 480

Caption = '我的服务测试程序'

Color = clBtnFace

Font.Charset = DEFAULT_CHARSET

Font.Color = clWindowText

Font.Height = -11

Font.Name = 'MS Sans Serif'

Font.Style = []

OldCreateOrder = False

OnCloseQuery = FormCloseQuery

OnCreate = FormCreate

OnDestroy = FormDestroy

PixelsPerInch = 96

TextHeight = 13

object Button1: TButton

Left = 296

Top = 264

Width = 75

Height = 25

Caption = 'Button1'

TabOrder = 0

OnClick = Button1Click

end

object Timer1: TTimer

OnTimer = Timer1Timer

Left = 120

Top = 192

end

如何加入自己服务程序的“描述”内容呢？

目前基本有两种方法：
1、修改注册表，在
HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet001\Services下找到自己的服务名称键值，然后加入一个名为Description的字符串字段，字段内容就是描述的内容。
这种方法通过实验是有效的，但因为不是通过API实现，而是直接写注册表，不太清楚适用性如何，不同的系统不知是否通用。

2、可通过ChangeServiceConfig2函数实现对服务的描述的修改。网上的ChangeServiceConfig2函数举例都根本无法成功运行，通过摸索改进，现提供ChangeServiceConfig2的正确用法如下，可成功有效地修改服务程序的描述。

程序代码

var

  sdBuf: SERVICE_DESCRIPTION;

  hSCManager, ServiceHandle: SC_Handle;

begin

  hSCManager := OpenSCManager(nil, SERVICES_ACTIVE_DATABASE, SC_MANAGER_ALL_Access);

  if hSCManager<>0 then

  try

    ServiceHandle := OpenService(hSCManager, PChar(ShutDownMonService.Name), SERVICE_CHANGE_CONFIG);

    if ServiceHandle<>0 then

    try

      sdBuf.lpDescription := '我们的描述写在这里。';

      ChangeServiceConfig2(ServiceHandle, SERVICE_CONFIG_DESCRIPTION, @sdBuf);

    finally

      CloseServiceHandle(ServiceHandle);

    end;

  finally

    CloseServiceHandle(hSCManager);

  end;

end;

以上的代码建议加在Service的AfterInstall事件中，当服务安装成功后自动对描述进行修改。一次性即可。

注意需要引用WinSvc, WinSvcEx两个单元，其中WinSvcEx的内容如下

程序代码

unit WinSvcEx;

interface

uses Windows, WinSvc;

const 

// 

// Service config info levels 

// 

SERVICE_CONFIG_DESCRIPTION = 1; 

SERVICE_CONFIG_FAILURE_ACTIONS = 2;

// 

// DLL name of imported functions 

// 

AdvApiDLL = 'advapi32.dll'; 

type 

// 

// Service description string 

// 

PServiceDescriptionA = ^TServiceDescriptionA; 

PServiceDescriptionW = ^TServiceDescriptionW; 

PServiceDescription = PServiceDescriptionA; 

{$EXTERNALSYM _SERVICE_DESCRIPTIONA} 

_SERVICE_DESCRIPTIONA = record 

lpDescription : PAnsiChar; 

end; 

{$EXTERNALSYM _SERVICE_DESCRIPTIONW} 

_SERVICE_DESCRIPTIONW = record 

lpDescription : PWideChar; 

end; 

{$EXTERNALSYM _SERVICE_DESCRIPTION} 

_SERVICE_DESCRIPTION = _SERVICE_DESCRIPTIONA; 

{$EXTERNALSYM SERVICE_DESCRIPTIONA} 

SERVICE_DESCRIPTIONA = _SERVICE_DESCRIPTIONA; 

{$EXTERNALSYM SERVICE_DESCRIPTIONW} 

SERVICE_DESCRIPTIONW = _SERVICE_DESCRIPTIONW; 

{$EXTERNALSYM SERVICE_DESCRIPTION} 

SERVICE_DESCRIPTION = _SERVICE_DESCRIPTIONA; 

TServiceDescriptionA = _SERVICE_DESCRIPTIONA; 

TServiceDescriptionW = _SERVICE_DESCRIPTIONW; 

TServiceDescription = TServiceDescriptionA;

// 

// Actions to take on service failure 

// 

{$EXTERNALSYM _SC_ACTION_TYPE} 

_SC_ACTION_TYPE = (SC_ACTION_NONE, SC_ACTION_RESTART, SC_ACTION_REBOOT, SC_ACTION_RUN_COMMAND);

{$EXTERNALSYM SC_ACTION_TYPE} 

SC_ACTION_TYPE = _SC_ACTION_TYPE;

PServiceAction = ^TServiceAction; 

{$EXTERNALSYM _SC_ACTION} 

_SC_ACTION = record 

aType : SC_ACTION_TYPE; 

Delay : DWORD; 

end; 

{$EXTERNALSYM SC_ACTION} 

SC_ACTION = _SC_ACTION; 

TServiceAction = _SC_ACTION;

PServiceFailureActionsA = ^TServiceFailureActionsA; 

PServiceFailureActionsW = ^TServiceFailureActionsW; 

PServiceFailureActions = PServiceFailureActionsA; 

{$EXTERNALSYM _SERVICE_FAILURE_ACTIONSA} 

_SERVICE_FAILURE_ACTIONSA = record 

dwResetPeriod : DWORD; 

lpRebootMsg : LPSTR; 

lpCommand : LPSTR; 

cActions : DWORD; 

lpsaActions : ^SC_ACTION; 

end; 

{$EXTERNALSYM _SERVICE_FAILURE_ACTIONSW} 

_SERVICE_FAILURE_ACTIONSW = record 

dwResetPeriod : DWORD; 

lpRebootMsg : LPWSTR; 

lpCommand : LPWSTR; 

cActions : DWORD; 

lpsaActions : ^SC_ACTION; 

end; 

{$EXTERNALSYM _SERVICE_FAILURE_ACTIONS} 

_SERVICE_FAILURE_ACTIONS = _SERVICE_FAILURE_ACTIONSA; 

{$EXTERNALSYM SERVICE_FAILURE_ACTIONSA} 

SERVICE_FAILURE_ACTIONSA = _SERVICE_FAILURE_ACTIONSA; 

{$EXTERNALSYM SERVICE_FAILURE_ACTIONSW} 

SERVICE_FAILURE_ACTIONSW = _SERVICE_FAILURE_ACTIONSW; 

{$EXTERNALSYM SERVICE_FAILURE_ACTIONS} 

SERVICE_FAILURE_ACTIONS = _SERVICE_FAILURE_ACTIONSA; 

TServiceFailureActionsA = _SERVICE_FAILURE_ACTIONSA; 

TServiceFailureActionsW = _SERVICE_FAILURE_ACTIONSW; 

TServiceFailureActions = TServiceFailureActionsA;

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

// API Function Prototypes 

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

TQueryServiceConfig2 = function (hService : SC_HANDLE; dwInfoLevel : DWORD; lpBuffer : pointer;

cbBufSize : DWORD; var pcbBytesNeeded) : BOOL; stdcall; 

TChangeServiceConfig2 = function (hService : SC_HANDLE; dwInfoLevel : DWORD; lpInfo : pointer) : BOOL; stdcall;

var 

hDLL : THandle ; 

LibLoaded : boolean ;

var 

OSVersionInfo : TOSVersionInfo;

{$EXTERNALSYM QueryServiceConfig2A} 

QueryServiceConfig2A : TQueryServiceConfig2; 

{$EXTERNALSYM QueryServiceConfig2W} 

QueryServiceConfig2W : TQueryServiceConfig2; 

{$EXTERNALSYM QueryServiceConfig2} 

QueryServiceConfig2 : TQueryServiceConfig2;

{$EXTERNALSYM ChangeServiceConfig2A} 

ChangeServiceConfig2A : TChangeServiceConfig2; 

{$EXTERNALSYM ChangeServiceConfig2W} 

ChangeServiceConfig2W : TChangeServiceConfig2; 

{$EXTERNALSYM ChangeServiceConfig2} 

ChangeServiceConfig2 : TChangeServiceConfig2;

implementation

initialization 

OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo); 

GetVersionEx(OSVersionInfo); 

if (OSVersionInfo.dwPlatformId = VER_PLATFORM_WIN32_NT) and (OSVersionInfo.dwMajorVersion >= 5) then

begin 

if hDLL = 0 then 

begin 

hDLL:=GetModuleHandle(AdvApiDLL); 

LibLoaded := False; 

if hDLL = 0 then 

begin 

hDLL := LoadLibrary(AdvApiDLL); 

LibLoaded := True; 

end; 

end;

if hDLL <> 0 then 

begin 

@QueryServiceConfig2A := GetProcAddress(hDLL, 'QueryServiceConfig2A'); 

@QueryServiceConfig2W := GetProcAddress(hDLL, 'QueryServiceConfig2W'); 

@QueryServiceConfig2 := @QueryServiceConfig2A; 

@ChangeServiceConfig2A := GetProcAddress(hDLL, 'ChangeServiceConfig2A'); 

@ChangeServiceConfig2W := GetProcAddress(hDLL, 'ChangeServiceConfig2W'); 

@ChangeServiceConfig2 := @ChangeServiceConfig2A; 

end; 

end 

else 

begin 

@QueryServiceConfig2A := nil; 

@QueryServiceConfig2W := nil; 

@QueryServiceConfig2 := nil; 

@ChangeServiceConfig2A := nil; 

@ChangeServiceConfig2W := nil; 

@ChangeServiceConfig2 := nil; 

end;

finalization 

if (hDLL <> 0) and LibLoaded then 

FreeLibrary(hDLL);

end.

另外delphi 自带的Delphi带了个例子，在source/vcl目录上有个ScktSrvr.dpr
有GUI的Service程序，写Service一般是按照这个方法来做。这样调试起来更方便。

推荐分享