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;
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;
(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 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;
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);
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;