用Delphi创建服务程序

delphi服务程序:用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/"删除这个服务.回到Delphi7IDE.
我们计划是为这个服务添加个主窗口,运行后任务栏显示图标,双击图标将显示主窗口,上面有个按钮,点击该按钮
将实现Ctrl+Alt+Del功能.
实际上,服务莫认是工作于Winlogon桌面,可以打开控制面板,查看我们刚才那个服务属性-->登陆,其中/"允许服
务和桌面交互/"是不打钩.如何办?呵呵,回到IDE,注意那个布尔属性:Interactive,当这个属性为True时候,该服务就
可以和桌面交互了.
File-->New-->Form为服务添加窗口FrmMain,单元保存为Unit_FrmMain,并且把这个窗口设置为手工创建.完
成后代码如下:
unit Unit_Main;
erface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs, Unit_FrmMain;
type
  TDelphiService = (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;
erface
uses
Windows, Messages, SysUtils, Variants, Classes, ShellApi, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls;
const
WM_TrayIcon = WM_USER + 1234;
type
TFrmMain = (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: TNotyIconData;
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;
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(TNotyIconData));
IconData.cbSize := SizeOf(TNotyIconData);
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_NotyIcon(NIM_ADD, @IconData);
end;
procedure TFrmMain.DelIconFromTray;
begin
Shell_NotyIcon(NIM_DELETE, @IconData);
end;
procedure TFrmMain.SysButtonMsg(var Msg: TMessage);
begin
(Msg.wParam = SC_CLOSE) or
(Msg.wParam = SC_MINIMIZE) then Hide
inherited; // 执行默认动作
end;
procedure TFrmMain.TrayIconMessage(var Msg: TMessage);
begin
(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);
(HDesk_WL <> 0) then
(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实际上存在多个桌面.例如屏幕传输会出现白屏,可能有两个原因:是系统处于锁定或未登陆桌
面, 2是处于屏幕保护桌面.这时候要将当前桌面切换到该桌面才能抓屏.
(3)有关服务和桌面交互,还有种动态切换思路方法.大概单元如下:
unit ServiceDesktop;
erface
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);
hwinstaUser = 0 then
begin
OutputDebugString(PChar(/'OpenWindowStation failed/' + SysErrorMessage(GetLastError)));
Result := false;
exit;
end;
not SetProcessWindowStation(hwinstaUser) then
begin
OutputDebugString(/'SetProcessWindowStation failed/');
Result := false;
exit;
end;
hdeskUser := OpenDesktop(DefaultDesktop, 0, FALSE, MAXIMUM_ALLOWED);
hdeskUser = 0 then
begin
OutputDebugString(/'OpenDesktop failed/');
SetProcessWindowStation(hwinstaSave);
CloseWindowStation(hwinstaUser);
Result := false;
exit;
end;
Result := SetThreadDesktop(hdeskUser);
not Result then
OutputDebugString(PChar(/'SetThreadDesktop/' + SysErrorMessage(GetLastError)));
end;
procedure DoneServiceDeskTop;
begin
// Restore window station and desktop.
SetThreadDesktop(hdeskSave);
SetProcessWindowStation(hwinstaSave);
hwinstaUser <> 0 then
CloseWindowStation(hwinstaUser);
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下.

第 2种思路方法就是先用
QueryServiceConfig2获取服务信息,然后ChangeServiceConfig2来改变描述.用Delphi实现话,单元如下:
unit WinSvcEx;
erface
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
//
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 _disibledevent=>{$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
dwRePeriod : DWORD;
lpRebootMsg : LPSTR;
lpCommand : LPSTR;
cActions : DWORD;
lpsaActions : ^SC_ACTION;
end;
{$EXTERNALSYM _SERVICE_FAILURE_ACTIONSW}
_SERVICE_FAILURE_ACTIONSW = record
dwRePeriod : 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 : poer;
cbBufSize : DWORD; var pcbBytesNeeded) : BOOL; stdcall;
TChangeServiceConfig2 = function (hService : SC_HANDLE; dwInfoLevel : DWORD; lpInfo : poer) :
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);
(OSVersionInfo.dwPlatformId = VER_PLATFORM_WIN32_NT) and (OSVersionInfo.dwMajorVersion >=
5) then
begin
hDLL = 0 then
begin
hDLL:=GetModuleHandle(AdvApiDLL);
LibLoaded := False;
hDLL = 0 then
begin
hDLL := LoadLibrary(AdvApiDLL);
LibLoaded := True;
end;
end;
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
begin
@QueryServiceConfig2A := nil;
@QueryServiceConfig2W := nil;
@QueryServiceConfig2 := nil;
@ChangeServiceConfig2A := nil;
@ChangeServiceConfig2W := nil;
@ChangeServiceConfig2 := nil;
end;
finalization
(hDLL <> 0) and LibLoaded then
FreeLibrary(hDLL);
end.
unit winntService;
erface
uses
Windows,WinSvc,WinSvcEx;
function InstallService(const strServiceName,strDisplayName,strDescription,strFilename: ):Boolean;
//eg:InstallService(/'服务名称/',/'显示名称/',/'描述信息/',/'服务文件/');
procedure UnService(strServiceName:);
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 2009-2-12 4:27:21
疯狂代码 http://www.crazycoder.cn/