用Delphi创建服务程序(delphi7)

2012-04-09  金城  2819

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

procedure TDelphiService.ServiceExecute(Sender:TService);
begin
while not Terminated do
begin
Sleep(10);
ServiceThread.ProcessRequests(False);
end;
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;
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.

补充:
(1)关于更多服务程序的演示程序,请访问以下Url:http://www.torry.net/pages.php?id=226,上面包含了多个演示如何控制和管理系统服务的代码.

(2)请切记:Windows实际上存在多个桌面.例如屏幕传输会出现白屏,可能有两个原因:一是系统处于锁定或未登陆桌面,二是处于屏幕保护桌面.这时候要将当前桌面切换到该桌面才能抓屏.

(3)关于服务程序与桌面交互,还有种动态切换方法.大概单元如下:

unit ServiceDesktop;

interface

function InitServiceDesktop:boolean;
procedure DoneServiceDeskTop;

implementation

uses Windows,SysUtils;

const
DefaultWindowStation = 'WinSta0';
DefaultDesktop = 'Default';
var
hwinstaSave:HWINSTA;
hdeskSave:HDESK;
hwinstaUser:HWINSTA;
hdeskUser:HDESK;
function InitServiceDesktop:boolean;
var
dwThreadId:DWORD;
begin
dwThreadId:= GetCurrentThreadID;
// Ensure connection to service window station and desktop,and
// save their handles.
hwinstaSave:= GetProcessWindowStation;
hdeskSave:= GetThreadDesktop(dwThreadId);


hwinstaUser:= OpenWindowStation(DefaultWindowStation,FALSE,MAXIMUM_ALLOWED);
if hwinstaUser = 0 then
begin
OutputDebugString(PChar('OpenWindowStation failed' SysErrorMessage(GetLastError)));
Result:= false;
exit;
end;

if not SetProcessWindowStation(hwinstaUser) then
begin
OutputDebugString('SetProcessWindowStation failed');
Result:= false;
exit;
end;

hdeskUser:= OpenDesktop(DefaultDesktop,0,FALSE,MAXIMUM_ALLOWED);
if hdeskUser = 0 then
begin
OutputDebugString('OpenDesktop failed');
SetProcessWindowStation(hwinstaSave);
CloseWindowStation(hwinstaUser);
Result:= false;
exit;
end;
Result:= SetThreadDesktop(hdeskUser);
if not Result then
OutputDebugString(PChar('SetThreadDesktop' SysErrorMessage(GetLastError)));
end;

procedure DoneServiceDeskTop;
begin
// Restore window station and desktop.
SetThreadDesktop(hdeskSave);
SetProcessWindowStation(hwinstaSave);
if hwinstaUser <>0 then
CloseWindowStation(hwinstaUser);
if hdeskUser <>0 then
CloseDesktop(hdeskUser);
end;

initialization
InitServiceDesktop;
finalization
DoneServiceDesktop;
end.

更详细的演示代码请参看:

(4)关于安装服务如何添加服务描述.有两种方法:一是修改注册表.服务的详细信息都位于HKEY_LOCAL_MACHINE\SYSTEM \ControlSet001\Services\下面,例如我们刚才那个服务就位于HKEY_LOCAL_MACHINE\SYSTEM \ControlSet001\Services\DelphiService下.第二种方法就是先用QueryServiceConfig2函数获取服 务信息,然后ChangeServiceConfig2来改变描述.用Delphi实现的话,单元如下:

 

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.

unit winntService;

interface

uses
Windows,WinSvc,WinSvcEx;

function InstallService(const strServiceName,strDisplayName,strDescription,strFilename:string):Boolean;
//eg:InstallService('服务名称','显示名称','描述信息','服务文件');
procedure UninstallService(strServiceName:string);
impleme ntation

function StrLCopy(Dest:PChar;const Source:PChar;MaxLen:Cardinal):PChar;assembler;
asm
PUSH EDI
PUSH ESI
PUSH EBX
MOV ESI,EAX
MOV EDI,EDX
MOV EBX,ECX
XOR AL,AL
TEST ECX,ECX
JZ @@1
REPNE SCASB
JNE @@1
INC ECX
@@1:SUB EBX,ECX
MOV EDI,ESI
MOV ESI,EDX
MOV EDX,EDI
MOV ECX,EBX
SHR ECX,2
REP MOVSD
MOV ECX,EBX
AND ECX,3
REP MOVSB
STOSB
MOV EAX,EDX
POP EBX
POP ESI
POP EDI
end;

function StrPCopy(Dest:PChar;const Source:string):PChar;
begin
Result:= StrLCopy(Dest,PChar(Source),Length(Source));
end;

function InstallService(const strServiceName,strDisplayName,strDescription,strFilename:string):Boolean;
var
//ss:TServiceStatus;
//psTemp:PChar;
hSCM,hSCS:THandle;

srvdesc:PServiceDescription;
desc:string;
//SrvType:DWord;

lpServiceArgVectors:pchar;
begin
Result:=False;
//psTemp:= nil;
//SrvType:= SERVICE_WIN32_OWN_PROCESS and SERVICE_INTERACTIVE_PROCESS;
hSCM:=OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);//连接服务数据库
if hSCM=0 then Exit;//MessageBox(hHandle,Pchar(SysErrorMessage(GetLastError)),'服务程序管理器',MB_ICONERROR MB_TOPMOST);


hSCS:=CreateService( //创建服务函数
hSCM,// 服务控制管理句柄
Pchar(strServiceName),// 服务名称
Pchar(strDisplayName),// 显示的服务名称
SERVICE_ALL_ACCESS,// 存取权利
SERVICE_WIN32_OWN_PROCESS or SERVICE_INTERACTIVE_PROCESS,// 服务类型 SERVICE_WIN32_SHARE_PROCESS
SERVICE_AUTO_START,// 启动类型
SERVICE_ERROR_IGNORE,// 错误控制类型
Pchar(strFilename),// 服务程序
nil,// 组服务名称
nil,// 组标识
nil,// 依赖的服务
nil,// 启动服务帐号
nil);// 启动服务口令
if hSCS=0 then Exit;//MessageBox(hHandle,Pchar(SysErrorMessage(GetLastError)),Pchar(Application.Title),MB_ICONERROR MB_TOPMOST);

if Assigned(ChangeServiceConfig2) then
begin
desc:= Copy(strDescription,1,1024);
GetMem(srvdesc,SizeOf(TServiceDescription));
GetMem(srvdesc^.lpDescription,Length(desc) 1);
try
StrPCopy(srvdesc^.lpDescription,desc);
ChangeServiceConfig2(hSCS,SERVICE_CONFIG_DESCRIPTION,srvdesc);
finally
FreeMem(srvdesc^.lpDescription);
FreeMem(srvdesc);
end;
end;
lpServiceArgVectors:= nil;
if not StartService(hSCS,0,lpServiceArgVectors) then //启动服务
Exit;//MessageBox(hHandle,Pchar(SysErrorMessage(GetLastError)),Pchar(Application.Title),MB_ICONERROR MB_TOPMOST);
CloseServiceHandle(hSCS);//关闭句柄
Result:=True;
end;

procedure UninstallService(strServiceName:string);
var
SCManager:SC_HANDLE;
Service:SC_HANDLE;
Status:TServiceStatus;
begin
SCManager:= OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
if SCManager = 0 then Exit;
try
Service:= OpenService(SCManager,Pchar(strServiceName),SERVICE_ALL_ACCESS);
ControlService(Service,SERVICE_CONTROL_STOP,Status);
DeleteService(Service);
CloseServiceHandle(Service);
finally
CloseServiceHandle(SCManager);
end;
end;

end.

(5)如何暴力关闭一个服务程序,实现我们以前那个"NT工具箱"的功能?首先,根据进程名称来杀死进程是用以下函数:
uses Tlhelp32;

function KillTask(ExeFileName:string):Integer;
const
PROCESS_TERMINATE = $0001;
var
ContinueLoop:BOOL;
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;

但是对于服务程序,它会提示"拒绝访问".其实只要程序拥有Debug权限即可:
function EnableDebugPrivilege:Boolean;
function EnablePrivilege(hToken:Cardinal;PrivName:string;bEnable:Boolean):Boolean;
var
TP:TOKEN_PRIVILEGES;
Dummy:Cardinal;
begin
TP.PrivilegeCount:= 1;
LookupPrivilegeValue(nil,pchar(PrivName),TP.Privileges[0].Luid);
if bEnable then
TP.Privileges[0].Attributes:= SE_PRIVILEGE_ENABLED
else TP.Privileges[0].Attributes:= 0;
AdjustTokenPrivileges(hToken,False,TP,SizeOf(TP),nil,Dummy);
Result:= GetLastError = ERROR_SUCCESS;
end;

var
hToken:Cardinal;
begin
OpenProcessToken(GetCurrentProcess,TOKEN_ADJUST_PRIVILEGES,hToken);
result:=EnablePrivilege(hToken,'SeDebugPrivilege',True);
CloseHandle(hToken);
end;

使用方法:
EnableDebugPrivilege;//提升权限
KillTask('xxxx.exe');//关闭该服务程序.

delphi系统服务服务程序