非常小巧的服务
下面的服务实际上是按照标准的Windows的服务编写过程来做，Delphi封装的服务的确不太好，一运行占用内存太多，同时线程数过多。
//------------------------------------------------------//
program DemoSrv;
// Windows NT Service Demo Program for Delphi 3
// By Tom Lee , Taiwan , Repubilc of China ( Tomm.bbs@csie.nctu.edu.t
w )
// JUL 8 1997
// ver 1.01
// The service will beep every 10 second .
uses SysUtils,Windows,WinSvc,Dialogs;
const
ServiceName='TomDemoService';
ServiceDisplayName='Tom Lee Demo Service';
SERVICE_WIN32_OWN_PROCESS=$00000010;
SERVICE_DEMAND_START=$00000003;
SERVICE_ERROR_NORMAL=$00000001;
EVENTLOG_ERROR_TYPE=$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_ARG
UMENT_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,@sS
tring,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) th
en
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) t
hen exit;
// Create the event object. The control handler function signals
// 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,Thand
lerFunction(@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) t
hen
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('123');
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,ServiceDi
splayName,
SERVICE_ALL_ACCESS,SERVICE_WIN32_OWN_PROCESS,SERVICE_DEMAND_
START,
SERVICE_ERROR_NORMAL,lpszPath,nil,nil,nil,nil,nil);
if (schService>0) then
begin
Writeln('Install Ok.');
CloseServiceHandle(schService);
end
else
// Writeln('123');
Writeln('Unable to install '+ServiceName+',CreateService F
ail.');
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_AL
L_ACCESS);
if (schService>0) then
begin
// Try to stop service at first
if ControlService(schService,SERVICE_CONTROL_STOP,ssSt
atus) then
begin
Write('Stopping Service ');
Sleep(1000);
while (QueryServiceStatus(schService,ssStatus)) d
o
begin
if ssStatus.dwCurrentState=SERVICE_STOP_PEND
ING 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:=TServiceMainFunction(@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.
//------------------------------------------------------//