Solved

Delphi 3 and NT services

Posted on 1998-04-20
4
340 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
  • 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

Free Tool: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

Suggested Solutions

Title # Comments Views Activity
JAudiorecorder record freezing the app 29 76
RESTRequest Parameter 4 43
how to change, disabled button color FMX ? 1 40
Tvertscrollbox like a whatsapp layout 5 36
This article explains how to create forms/units independent of other forms/units object names in a delphi project. Have you ever created a form for user input in a Delphi project and then had the need to have that same form in a other Delphi proj…
In my programming career I have only very rarely run into situations where operator overloading would be of any use in my work.  Normally those situations involved math with either overly large numbers (hundreds of thousands of digits or accuracy re…
Nobody understands Phishing better than an anti-spam company. That’s why we are providing Phishing Awareness Training to our customers. According to a report by Verizon, only 3% of targeted users report malicious emails to management. With compan…
In a recent question (https://www.experts-exchange.com/questions/29004105/Run-AutoHotkey-script-directly-from-Notepad.html) here at Experts Exchange, a member asked how to run an AutoHotkey script (.AHK) directly from Notepad++ (aka NPP). This video…

829 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