|
用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}
本文关键：用Delphi创建服务程序
相关方案
本站最佳浏览方式为 分辨率 1024x768 IE 6.0（或更高版本的 IE浏览器） 
|