小巧的服务程序源码(转)
前段时间因要写服务程，但发现程序比较大，不包含窗口类的情况下都要120K以上！实在是太大了！ svchost.exe服务程序的大小才 7.76 KB，我想服务程序可以写的很小！
我在网上找找了好长时间终于给我找到精简的服务程序的DELPHI代码(好的DELPHI代码实在是少啊)， 我把源代码放上来和大家分享！
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 = $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_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.
（此文原出处：http://www.delphifans.com/infoview/Article_704.html）
