Avatar of John
JohnFlag for United Kingdom of Great Britain and Northern Ireland

asked on 

Delphi Windows Service 'running' but without action

I am trying to create a very simple Windows service. It runs fine (ie, beeps, logs) in debugging (console), and it installs fine and shows 'running' from Services however nothing is actually happening. Service Stops fine when requested. Same behaviour on alternative machines.

Project file:

PROGRAM ServiceProject;
{$ifdef DEBUG}
{$APPTYPE CONSOLE} {$endif} USES   Vcl.SvcMgr,   ServiceUnit IN 'ServiceUnit.pas', System.SysUtils{TestingService: TService}; {$R *.RES} BEGIN {$IFDEF DEBUG}   TRY     //In debug mode the server acts as a console application.     WriteLn('MyServiceApp DEBUG mode. Press enter to exit.');     //Create the TService descendant manually.     TestingService := TTestingService.Create(NIL);     //Simulate service start.     TestingService.ServiceExecute(TestingService);     //Keep the console box running (ServerContainer1 code runs in the background)     ReadLn;     //On exit, destroy the service object.     FreeAndNil(TestingService);   EXCEPT     ON E: Exception DO       BEGIN         WriteLn(E.ClassName, ': ', E.Message);         WriteLn('Press enter to exit.');         ReadLn;       END;   END; {$ELSE}   //Run as a true windows service (release).   IF NOT Application.DelayInitialize OR Application.Installing THEN     Application.Initialize;   Application.CreateForm(TTestingService, TestingService);   Application.Run; {$ENDIF} END.

Open in new window


UNIT ServiceUnit;
INTERFACE   USES     Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.SvcMgr, Vcl.Dialogs;   TYPE     TTestingService = CLASS(TService)       PRIVATE         {Private declarations}       PUBLIC         FUNCTION GetServiceController: TServiceController; OVERRIDE;         PROCEDURE ServiceExecute(Sender: TService);         {Public declarations}     END;   VAR     TestingService: TTestingService; IMPLEMENTATION {$R *.dfm}   PROCEDURE ServiceController(CtrlCode: DWord); STDCALL;     BEGIN       TestingService.Controller(CtrlCode);     END;   FUNCTION TTestingService.GetServiceController: TServiceController;     BEGIN       Result := ServiceController;     END;   PROCEDURE TTestingService.ServiceExecute(Sender: TService);     CONST       SecBetweenRuns = 5;     VAR       Count: Integer;     BEGIN       LogMessage(datetimetostr(Now()) + ' : ServiceExecute', EVENTLOG_INFORMATION_TYPE, 0, 2);       Count := 0;       WHILE NOT Terminated DO         BEGIN           Inc(Count);           IF Count >= SecBetweenRuns THEN             BEGIN               Count := 0;               beep;               LogMessage(datetimetostr(Now()) + ' : WHILE NOT Terminated DO', EVENTLOG_INFORMATION_TYPE, 0, 2);             END;           Sleep(1000);         END;     END; END.

Open in new window

The Service /install fine as Administrator, going to Services the service starts and shows 'running'.. but no beeps, no Event Log. Service stops fine when requested.

What am I doing wrong?

Many thanks

Delphi 10 Seattle 64
Windows 10 Home 64
Windows 2016 Server 64

DelphiWindows OSWindows Server 2016Windows 10Azure

Avatar of undefined
Last Comment
Avatar of Lukasz Zielinski
Lukasz Zielinski
Flag of Poland image

I don't think >>beep<< will work in service application.
so try to remove it.
Also call:
in your man service loop instead of your Sleep(1000); (then obviously you have to change the way you calculate SecBetweenRuns)

Avatar of ste5an
Flag of Germany image

Blurred text
View this solution by signing up for a free trial.
Members can start a 7-Day free trial and enjoy unlimited access to the platform.
See Pricing Options
Start Free Trial
Windows OS
Windows OS

This topic area includes legacy versions of Windows prior to Windows 2000: Windows 3/3.1, Windows 95 and Windows 98, plus any other Windows-related versions including Windows Mobile.

Top Experts
Get a personalized solution from industry experts
Ask the experts
Read over 600 more reviews


IBM logoIntel logoMicrosoft logoUbisoft logoSAP logo
Qualcomm logoCitrix Systems logoWorkday logoErnst & Young logo
High performer badgeUsers love us badge
LinkedIn logoFacebook logoX logoInstagram logoTikTok logoYouTube logo