精华区 [关闭][返回]

当前位置:网易精华区>>讨论区精华>>编程开发>>● Delphi>>其他>>Re: 如何用DELPHI做NT的SERVER??

主题:Re: 如何用DELPHI做NT的SERVER??
发信人: topgun2@GZ()
整理人: delfan(2001-03-30 21:53:45), 站内信件

标  题: Re: 如何用DELPHI做NT的SERVER??
发信站: 网易虚拟社区 (Mon Mar 20 18:48:42 2000), 站内信件

【 在 lhaoyue (tt) 的大作中提到: 】
: File|New中选SERVER,可不会用。Demo中又找不到例子。如何做呢??

还是我,你的E_mail找不到, 关键代码只好贴在此, 不明白就给我写Mail:
//------------------------------------------------------//
program DemoSrv;

// Windows NT Service Demo Program for Delphi 3
// By Tom Lee , Taiwan , Repubilc of China  ( [email protected]
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.
//------------------------------------------------------//


--
※ 来源:.月光软件站 http://www.moon-soft.com.[FROM: 202.109.88.65]

[关闭][返回]