用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; {$EXTERNAL[1] [2] 下一页 |