Solved

Delphi 3 and NT services

Posted on 1998-04-20
4
342 Views
Last Modified: 2010-04-06
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
0
Comment
Question by:valhala
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 2
4 Comments
 
LVL 1

Expert Comment

by:Greedy
ID: 1335638
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
 
LVL 2

Expert Comment

by:freter
ID: 1335639
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
 
LVL 1

Expert Comment

by:Greedy
ID: 1335640
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
 

Accepted Solution

by:
phillipf earned 100 total points
ID: 1335641
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

Featured Post

On Demand Webinar - Networking for the Cloud Era

This webinar discusses:
-Common barriers companies experience when moving to the cloud
-How SD-WAN changes the way we look at networks
-Best practices customers should employ moving forward with cloud migration
-What happens behind the scenes of SteelConnect’s one-click button

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

A lot of questions regard threads in Delphi.   One of the more specific questions is how to show progress of the thread.   Updating a progressbar from inside a thread is a mistake. A solution to this would be to send a synchronized message to the…
Introduction The parallel port is a very commonly known port, it was widely used to connect a printer to the PC, if you look at the back of your computer, for those who don't have newer computers, there will be a port with 25 pins and a small print…
Email security requires an ever evolving service that stays up to date with counter-evolving threats. The Email Laundry perform Research and Development to ensure their email security service evolves faster than cyber criminals. We apply our Threat…
A short tutorial showing how to set up an email signature in Outlook on the Web (previously known as OWA). For free email signatures designs, visit https://www.mail-signatures.com/articles/signature-templates/?sts=6651 If you want to manage em…

733 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question