Delphi小巧的Windows NT服务程序源码

Love The Way You Lie 2021-11-22 02:50 343阅读 0赞

program DemoSrv;  
  
// Windows NT Service Demo Program for Delphi 3  
// By Tom Lee , Taiwan , Repubilc of China ( Tomm.bbs@csie.nctu.edu.tw )  
// JUL 8 1997  
// ver 1.01  
// The service will beep every 10 second .  
  
  
uses SysUtils, Windows, WinSvc;  
  
const  
ServiceName = 'TomDemoService';  
ServiceDisplayName = 'd99 test Service';  
SERVICE\_WIN32\_OWN\_PROCESS = [$][Link 1]00000010;  
SERVICE\_DEMAND\_START = [$][Link 1]00000003;  
SERVICE\_ERROR\_NORMAL = [$][Link 1]00000001;  
EVENTLOG\_ERROR\_TYPE = [$][Link 1]0001;  
  
// declare global variable  
var  
ServiceStatusHandle: SERVICE\_STATUS\_HANDLE;  
ssStatus: TServiceStatus;  
dwErr: DWORD;  
ServiceTableEntry: array\[0..1\] of TServiceTableEntry;  
hServerStopEvent: THandle;  
  
// Get error message  
  
function GetLastErrorText: string;  
var  
dwSize: DWORD;  
lpszTemp: LPSTR;  
begin  
dwSize := 512;  
lpszTemp := nil;  
try  
GetMem(lpszTemp, dwSize);  
FormatMessage(FORMAT\_MESSAGE\_FROM\_SYSTEM or FORMAT\_MESSAGE\_ARGUMENT\_ARRAY,  
nil, GetLastError, LANG\_NEUTRAL, lpszTemp, dwSize, nil);  
finally  
Result := StrPas(lpszTemp);  
FreeMem(lpszTemp);  
end;  
end;  
  
// Write error message to Windows NT Event Log  
  
procedure AddToMessageLog(sMsg: string);  
var  
sString: array\[0..1\] of string;  
hEventSource: THandle;  
begin  
hEventSource := RegisterEventSource(nil, ServiceName);  
  
if hEventSource > 0 then  
begin  
sString\[0\] := ServiceName + ' error: ' + IntToStr(dwErr);  
sString\[1\] := sMsg;  
ReportEvent(hEventSource, EVENTLOG\_ERROR\_TYPE, 0, 0, nil, 2, 0, @sString, nil);  
DeregisterEventSource(hEventSource);  
end;  
end;  
  
function ReportStatusToSCMgr(dwState, dwExitCode, dwWait: DWORD): BOOL;  
begin  
Result := True;  
with ssStatus do  
begin  
if (dwState = SERVICE\_START\_PENDING) then  
dwControlsAccepted := 0  
else  
dwControlsAccepted := SERVICE\_ACCEPT\_STOP;  
  
dwCurrentState := dwState;  
dwWin32ExitCode := dwExitCode;  
dwWaitHint := dwWait;  
  
if (dwState = SERVICE\_RUNNING) or (dwState = SERVICE\_STOPPED) then  
dwCheckPoint := 0  
else  
inc(dwCheckPoint);  
end;  
  
Result := SetServiceStatus(ServiceStatusHandle, ssStatus);  
if not Result then AddToMessageLog('SetServiceStauts');  
end;  
  
procedure ServiceStop;  
begin  
if (hServerStopEvent > 0) then  
begin  
SetEvent(hServerStopEvent);  
end;  
end;  
  
procedure ServiceStart;  
var  
dwWait: DWORD;  
begin  
// Report Status  
if not ReportStatusToSCMgr(SERVICE\_START\_PENDING, NO\_ERROR, 3000) then exit;  
  
// this event when it receives the "stop" control code.  
hServerStopEvent := createEvent(nil, TRUE, False, nil);  
if hServerStopEvent = 0 then  
begin  
AddToMessageLog('createEvent');  
exit;  
end;  
  
if not ReportStatusToSCMgr(SERVICE\_RUNNING, NO\_ERROR, 0) then  
begin  
CloseHandle(hServerStopEvent);  
exit;  
end;  
  
// Service now running , perform work until shutdown  
while True do  
begin  
// Wait for Terminate  
MessageBeep(1);  
dwWait := WaitforSingleObject(hServerStopEvent, 1);  
if dwWait = WAIT\_OBJECT\_0 then  
begin  
CloseHandle(hServerStopEvent);  
exit;  
end;  
Sleep(1000 \* 10);  
end;  
end;  
  
procedure Handler(dwCtrlCode: DWORD); stdcall;  
begin  
// Handle the requested control code.  
case dwCtrlCode of  
  
SERVICE\_CONTROL\_STOP:  
begin  
ReportStatusToSCMgr(SERVICE\_STOP\_PENDING, NO\_ERROR, 0);  
ServiceStop;  
ReportStatusToSCMgr(SERVICE\_STOPPED, GetLastError, 0);  
exit;  
end;  
  
SERVICE\_CONTROL\_INTERROGATE:  
begin  
end;  
  
SERVICE\_CONTROL\_PAUSE:  
begin  
end;  
  
SERVICE\_CONTROL\_CONTINUE:  
begin  
end;  
  
SERVICE\_CONTROL\_SHUTDOWN:  
begin  
end;  
  
// invalid control code  
else  
end;  
  
// update the service status.  
ReportStatusToSCMgr(ssStatus.dwCurrentState, NO\_ERROR, 0);  
end;  
  
procedure ServiceMain;  
begin  
// Register the handler function with dispatcher;  
ServiceStatusHandle := RegisterServiceCtrlHandler(ServiceName, ThandlerFunction(@Handler));  
if ServiceStatusHandle = 0 then  
begin  
ReportStatusToSCMgr(SERVICE\_STOPPED, GetLastError, 0);  
exit;  
end;  
  
ssStatus.dwServiceType := SERVICE\_WIN32\_OWN\_PROCESS;  
ssStatus.dwServiceSpecificExitCode := 0;  
ssStatus.dwCheckPoint := 1;  
  
// Report current status to SCM (Service Control Manager)  
if not ReportStatusToSCMgr(SERVICE\_START\_PENDING, NO\_ERROR, 3000) then  
begin  
ReportStatusToSCMgr(SERVICE\_STOPPED, GetLastError, 0);  
exit;  
end;  
  
// Start Service  
ServiceStart;  
end;  
  
procedure InstallService;  
var  
schService: SC\_HANDLE;  
schSCManager: SC\_HANDLE;  
lpszPath: LPSTR;  
dwSize: DWORD;  
begin  
dwSize := 512;  
GetMem(lpszPath, dwSize);  
if GetModuleFileName(0, lpszPath, dwSize) = 0 then  
begin  
FreeMem(lpszPath);  
Writeln('Unable to install ' + ServiceName + ',GetModuleFileName Fail.');  
exit;  
end;  
FreeMem(lpszPath);  
  
schSCManager := OpenSCManager(nil, nil, SC\_MANAGER\_ALL\_ACCESS);  
if (schSCManager > 0) then  
begin  
schService := createService(schSCManager, ServiceName, ServiceDisplayName,  
SERVICE\_ALL\_ACCESS, SERVICE\_WIN32\_OWN\_PROCESS, SERVICE\_DEMAND\_START,  
SERVICE\_ERROR\_NORMAL, pchar(ParamStr(0)), nil, nil, nil, nil, nil);  
if (schService > 0) then  
begin  
Writeln('Install Ok.');  
CloseServiceHandle(schService);  
end  
else  
Writeln('Unable to install ' + ServiceName + ',createService Fail.');  
end  
else  
Writeln('Unable to install ' + ServiceName + ',OpenSCManager Fail.');  
  
end;  
  
procedure UnInstallService;  
var  
schService: SC\_HANDLE;  
schSCManager: SC\_HANDLE;  
begin  
schSCManager := OpenSCManager(nil, nil, SC\_MANAGER\_ALL\_ACCESS);  
if (schSCManager > 0) then  
begin  
schService := OpenService(schSCManager, ServiceName, SERVICE\_ALL\_ACCESS);  
if (schService > 0) then  
begin  
// Try to stop service at first  
if ControlService(schService, SERVICE\_CONTROL\_STOP, ssStatus) then  
begin  
Write('Stopping Service ');  
Sleep(1000);  
while (QueryServiceStatus(schService, ssStatus)) do  
begin  
if ssStatus.dwCurrentState = SERVICE\_STOP\_PENDING then  
begin  
Write('.');  
Sleep(1000);  
end  
else  
break;  
end;  
writeln;  
  
if ssStatus.dwCurrentState = SERVICE\_STOPPED then  
Writeln('Service Stop Now')  
else  
begin  
CloseServiceHandle(schService);  
CloseServiceHandle(schSCManager);  
Writeln('Service Stop Fail');  
exit;  
end;  
end;  
  
// Remove the service  
if (deleteService(schService)) then  
Writeln('Service Uninstall Ok.')  
else  
Writeln('deleteService fail (' + GetLastErrorText + ').');  
  
CloseServiceHandle(schService);  
end  
else  
Writeln('OpenService fail (' + GetLastErrorText + ').');  
  
CloseServiceHandle(schSCManager);  
end  
else  
Writeln('OpenSCManager fail (' + GetLastErrorText + ').');  
end;  
  
// Main Program Begin  
begin  
if (ParamCount = 1) then  
begin  
if ParamStr(1) = '/?' then  
begin  
Writeln('----------------------------------------');  
Writeln('DEMOSRV usage help');  
Writeln('----------------------------------------');  
Writeln('DEMOSRV /install to install the service');  
Writeln('DEMOSRV /remove to uninstall the service');  
Writeln('DEMOSRV /? Help');  
Halt;  
end;  
  
if Uppercase(ParamStr(1)) = '/INSTALL' then  
begin  
InstallService;  
Halt;  
end;  
  
if Uppercase(ParamStr(1)) = '/REMOVE' then  
begin  
UnInstallService;  
Halt;  
end;  
end;  
  
// Setup service table which define all services in this process  
with ServiceTableEntry\[0\] do  
begin  
lpServiceName := ServiceName;  
lpServiceProc := @ServiceMain;  
end;  
  
// Last entry in the table must have nil values to designate the end of the table  
with ServiceTableEntry\[1\] do  
begin  
lpServiceName := nil;  
lpServiceProc := nil;  
end;  
  
if not StartServiceCtrlDispatcher(ServiceTableEntry\[0\]) then  
begin  
AddToMessageLog('StartServiceCtrlDispatcher Error!');  
Halt;  
end;  
end.

转载于:https://www.cnblogs.com/MaxWoods/archive/2006/01/05/311358.html

[Link 1]: http://hackbase.com/News/hk/2005102914691.html#