Delphi 3 and NT services

I need to write an application that runs as an nt service in delphi 3, the application needs to wake up once and hour and execute a database read.

I have never tackled an nt service, and there are not many resources I have found that can tackle this problem.

Thanks

Roy
valhalaAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

GreedyCommented:
opalis robot can prbably do it.
http://www.opalis.com
but it cost alot.  To start a service don't you just tell NT that the application is a system application.  I mean what your discribing as your service dosn't sound like a service to me...I think of service as somthing that serves data and gets it...like a mail server it runs on a port like a deamon in unix.  But maby I'm wrong...probably am as I have never done either one.  I mean are you looking at security...and you don't want this to interact with the desktop right.  so wouldn't that just be a system application?  or do you need it to like respond to packets and things.


0
freterCommented:
Have you taken a look at the Delphi Super Page (http://sunsite.icm.edu.pl/delphi) ? You can find an archive named ntservc.zip that implements a so-called "beep" service that beeps every one second. If you adjust this interval, you'd just have what you want to have.
BTW: If you are low on memory, it's probably better do implement a service using any non-OOP langauge, since services written in Delphi or VC++ tend to produce an overhead of roundabout 1MB in memory!
0
GreedyCommented:
take a look at
http://ourworld.compuserve.com/homepages/African_Chief/
he has something on the page called Chief's Utilities ??? some kind of application processor.
0
phillipfCommented:
Try this.

program DemoSrv;

uses
  Forms,
  SysUtils,
  Windows,
  WinSvc,
  Dialogs,
  main in 'main.pas' {formmain},
  echo in 'echo.pas' {Form1};

Const
  ServiceName='DemoService';
  ServiceDisplayName='Demo Service';
  SERVICE_WIN32_OWN_PROCESS = $00000010;
  SERVICE_DEMAND_START = $00000003;
  SERVICE_ERROR_NORMAL = $00000001;
  EVENTLOG_ERROR_TYPE = $0001;

Var
  ServiceStatusHandle : SERVICE_STATUS_HANDLE;
  ssStatus: TServiceStatus;
  dwErr : DWORD;
  ServiceTableEntry : Array[0..1] of TServiceTableEntry;
  hServerStopEvent : THandle;

{$R *.RES}

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;

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('SetServiceStatus');
End;

Procedure ServiceStop;
Begin
  if (hServerStopEvent > 0) then
    SetEvent(hServerStopEvent);
End;

Procedure ServiceStart;
Var
  dwWait : DWORD;
begin
  if not ReportStatusToSCMgr(SERVICE_START_PENDING, NO_ERROR, 3000) Then
    Exit;
  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;

  While True do
  begin
    //** Your code would go here.  In this example I running **//
    //** an pplication the I previously created as a non     **//
    //** service.  If you do this make sure you trap all     **//
    //** exceptions since this would cause a dialog box to   **//
    //** be displayed but not seen since it is running as a  **//
    //** service.  I know this code works since I have used  **//
    //** it in numerous programs.  Good luck.                **//

    //** I can not take credit for this code.Unfortunately   **//
    //** I can not remeber where I got it from               **//

    //** Also note that this sample needs to be compiled as  **//
    //** a console application but that can be changed.      **//

    Application.Initialize;
    Application.CreateForm(Tformmain, formmain);
    Application.Run;

   //*********************************************************//
    dwWait := WaitForSingleObject(hServerStopEvent,1);
    if dwWait=WAIT_OBJECT_0 then
    begin
      CloseHandle(hServerStopEvent);
      exit;
    end;
  end;
end;

procedure Handler(dwCtrlCode:DWORD);stdcall;
begin
  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;

    else
  end;

  ReportStatusToSCMgr(ssStatus.dwCurrentState, NO_ERROR, 0);
end;

procedure ServiceMain;
begin
  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;

  if not ReportStatusToSCMgr(SERVICE_START_PENDING, NO_ERROR, 3000) then
  begin
    ReportStatusToSCMgr(SERVICE_STOPPED, GetLastError, 0);
    exit;
  end;

  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+',OpenSCManger 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
      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;

      if (DeleteService(schService)) then
        Writeln('Service Uninstall OK.')
      else
        Writeln('Delete Service Fail ('+GetLastErrorText+').');

      CloseServiceHandle(schService);
    end
    else
      Writeln('Open Service Fail ('+GetLastErrorText+').');

    CloseServiceHandle(schSCManager);
  end
  else
    Writeln('Open SCManager Fail ('+GetLastErrorText+').');
end;

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 unistall 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;

  With ServiceTableEntry[0] Do
  Begin
    lpServiceName := ServiceName;
    lpServiceProc := TServiceMainFunction(@ServiceMain);
  end;

  With ServiceTableEntry[1] do
  begin
    lpServiceName := nil;
    lpServiceProc := nil;
  end;

  If not StartServiceCtrlDispatcher(ServiceTableEntry[0]) Then
  begin
    AddToMessageLog('StartServiceCtrlDispatcher Error!');
    Halt;
  end;
end.
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Delphi

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.