[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 262
  • Last Modified:

Applicatiuon running in service under WinNT

Hi Yee,

I've got a problem. I'd like to write a program wich runs
under WindowsNT, among the services.
How can I do that?

Thanks in advance

Andrew
0
bandi081497
Asked:
bandi081497
  • 2
1 Solution
 
altenaCommented:
You can, but it will be hard.

I prefer to write these in C/C++, but there is
no reason why you cannot do this in Delphi.

Read all material on services from the microsoft developer
network (available online: www.microsoft.com/msdn)

I learned a lot from the "simple-service" sample (in c) that
is in the win32-SDK. You should download that one too from the
msdn site.

But take your time, as this will not be easy.
0
 
greendotCommented:
Here is a code example I picked up a while back somewhere...
I'm not sure if it works or not.  I have yet to compile it, but it might be your answer.

---------------------------------------------------------

unit DemoService;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, StdCtrls, WinSvc;

const
     ServiceName='DemoService';  

type
  TfrmMain = class(TForm)
    cmdStart: TButton;
    cmdStop: TButton;
    stsMessage: TStatusBar;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure cmdStopClick(Sender: TObject);
    procedure cmdStartClick(Sender: TObject);
  private
    { Private declarations }
    schService:SC_HANDLE;
    schSCManager:SC_HANDLE;
    ssStatus:TServiceStatus;
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.DFM}


procedure TfrmMain.FormCreate(Sender: TObject);
begin
     schSCManager:=OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
     if (schSCManager<=0) then
     begin
          MessageDlg('Demo Service is not installed.',mtError,[mbOk],0);
          Application.Terminate;
     end;

     schService:=OpenService(schSCManager,ServiceName,SERVICE_ALL_ACCESS);
     if (schService<=0) then
     begin
          MessageDlg('Demo Service can not open.',mtError,[mbOk],0);
          Application.Terminate;
     end;
end;

procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
     CloseServiceHandle(schService);
     CloseServiceHandle(schSCManager);
end;

procedure TfrmMain.cmdStopClick(Sender: TObject);
begin
     if ControlService(schService,SERVICE_CONTROL_STOP,ssStatus) then
     begin
          stsMessage.SimpleText:='Stopping Service Now ';
          Sleep(1000);
          while (QueryServiceStatus(schService,ssStatus)) do
          begin
               Application.ProcessMessages;
               if ssStatus.dwCurrentState=SERVICE_STOP_PENDING then
               begin
                    stsMessage.SimpleText:=stsMessage.SimpleText+('.');
                    Sleep(1000);
               end
               else
                   break;
          end;

          if ssStatus.dwCurrentState=SERVICE_STOPPED then
              stsMessage.SimpleText:='Service Stop Ok'
          else
              stsMessage.SimpleText:='Service Stop Fail';
     end
     else
         stsMessage.SimpleText:='Service Stop Fail';
end;

procedure TfrmMain.cmdStartClick(Sender: TObject);
var
   Argv:PChar;
begin
     if StartService(schService,0,Argv) then
     begin
          stsMessage.SimpleText:='Start Service Now ';
          Sleep(1000);
          while (QueryServiceStatus(schService,ssStatus)) do
          begin
               Application.ProcessMessages;
               if ssStatus.dwCurrentState=SERVICE_START_PENDING then
               begin
                    stsMessage.SimpleText:=stsMessage.SimpleText+('.');
                    Sleep(1000);
               end
               else
                   break;
          end;

          if ssStatus.dwCurrentState=SERVICE_RUNNING then
              stsMessage.SimpleText:='Service Start Ok'
          else
              stsMessage.SimpleText:='Service Start Fail';
     end
     else
          stsMessage.SimpleText:='Service Start Fail';
end;

end.

0
 
greendotCommented:
Geeeeeze, you're tough.

Actually, I went and played around with it and got something to work.
I verified this on my machine.  If you want a service in Delphi, this works.
Right now it is a console application, but you can change that easilly.

---------------------------------------
program DemoSrv;

// Windows NT Service Demo Program for Delphi 3
// The service will beep every 10 second .

uses SysUtils, Windows, WinSvc, Dialogs;

const
     ServiceName = 'DemoService';
     ServiceDisplayName = '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;

//---------------------------------------------------------------------------------------------
function GetLastErrorText: string;
// Get error message
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; {try/finally}
end;

//---------------------------------------------------------------------------------------------
procedure AddToMessageLog(sMsg:string);
// Write error message to Windows NT Event Log
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; {if}
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; {with}

   result := SetServiceStatus(ServiceStatusHandle, ssStatus);
   if not result then AddToMessageLog('SetServiceStauts');
end;

//---------------------------------------------------------------------------------------------
procedure ServiceStop;
begin
   if (hServerStopEvent > 0) then
      SetEvent(hServerStopEvent);
end;

//---------------------------------------------------------------------------------------------
procedure ServiceStart;
var
   dwWait: DWORD;
begin
   // Report Status
   if not ReportStatusToSCMgr(SERVICE_START_PENDING, NO_ERROR, 3000) then 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,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,lpszPath,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:=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.


0

Featured Post

[Webinar] Cloud and Mobile-First Strategy

Maybe you’ve fully adopted the cloud since the beginning. Or maybe you started with on-prem resources but are pursuing a “cloud and mobile first” strategy. Getting to that end state has its challenges. Discover how to build out a 100% cloud and mobile IT strategy in this webinar.

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now