小巧的系統服務程式 - Delphi - bestlong 怕失憶論壇

bestlong 怕失憶論壇 › 論壇 › Delphi › 小巧的系統服務程式

查看: 5708\|回復: 0	go 小巧的系統服務程式 [複製鏈接]

bestlong

管理員

Rank: 9 Rank: 9 Rank: 9

1^#

發表於 2006-10-17 13:41 |只看該作者 |倒序瀏覽 |打印

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.

複製代碼

收藏0 分享0

我是雪龍
http://blog.bestlong.idv.tw
http://www.bestlong.idv.tw

回復引用

舉報返回頂部

‹ 上一主題|下一主題 ›

返回列表

關閉 安全驗證

小巧的系統服務程式 [複製鏈接]

關閉安全驗證