用Delphi创建服务程序
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.
更详细的演示代码请参看: http: //www.torry.net/samples/samples/os/isarticle.zip
(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);
implementation
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 = 01;
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); //关闭该服务程序.
（此文原出处：http://www.programbbs.com/doc/379.htm）
