Service Control

Another option for Control Panel >Administrative Tools > Services

Service Control [with install, uninstall, run, stop, leave]

Service Control [with install, uninstall, run, stop, leave]

The Project File:

ServiceControl.lpr Pascal (776 bytes) 25.10.2015 23:53
// *****************************************************************************
//  Title.............. :  Service Control Project
//
//  Modulname ......... :  ServiceControl.lpr
//  Type .............. :  Lazarus Project File
//  Author ............ :  Udo Schmal
//  Development Status  :  26.10.2015
//  Operating System .. :  Win32/Win64
//  IDE ............... :  Lazarus
// *****************************************************************************
program ServiceControl;

{$mode objfpc}{$H+}

uses
  Interfaces, Forms, Main;

{$R *.res}

begin
  Application.Title:='Service Control';
  RequireDerivedFormResource := True;
  Application.Initialize;
  Application.CreateForm(TfrmServiceControl, frmServiceControl);
  Application.Run;
end.

The Form File: (in this example for my webserver)

main.pas Pascal (9,11 kByte) 25.10.2015 23:51
// *****************************************************************************
//  Title.............. :  Service Control Main
//
//  Modulname ......... :  main.pas (TfrmServiceControl)
//  Type .............. :  Unit
//  Author ............ :  Udo Schmal
//  Development Status  :  26.10.2015
//  Operating System .. :  Win32/Win64
//  IDE ............... :  Lazarus
// *****************************************************************************
unit Main;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
  {$ifdef USE_SHELLAPI}Windows, ShellApi,{$else}Process,{$endif}
  {$ifdef USE_REGISTRY}Registry,{$endif}
  Menus, ServiceManager, JwaWinSvc, TaskScheduler_1_0_TLB;

const
  ServiceName = 'httpServer';
  ServiceTitel = 'UDOs Webserver';
  ServiceExecutable = 'httpServer.exe';

type
  TfrmServiceControl = class(TForm)
    ImageList: TImageList;
    leave: TMenuItem;
    install: TMenuItem;
    uninstall: TMenuItem;
    stop: TMenuItem;
    start: TMenuItem;
    TrayMenu: TPopupMenu;
    TrayIcon: TTrayIcon;
    procedure FormCloseQuery(Sender: TObject; var CanClose: boolean);
    procedure FormCreate(Sender: TObject);
    procedure installClick(Sender: TObject);
    procedure leaveClick(Sender: TObject);
    procedure TrayMenuPopup(Sender: TObject);
    procedure startClick(Sender: TObject);
    procedure stopClick(Sender: TObject);
    procedure TrayIconMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure uninstallClick(Sender: TObject);
  private
    FPath: string;
    FServiceIsInstalled, FServiceIsRunning: Boolean;
    procedure SetAutoStart(bRegister: Boolean);
    procedure UpdateServiceStatus();
  end;

var
  frmServiceControl: TfrmServiceControl;

implementation

{$R *.lfm}

{$ifdef USE_SHELLAPI}
function RunAsAdmin(const Handle: Hwnd; const Path: string; Params: string = ''): Boolean;
var
  sei: TShellExecuteInfoA;
begin
  FillChar(sei, SizeOf(sei), 0);
  sei.cbSize := SizeOf(sei);
  sei.Wnd := Handle;
  sei.fMask := SEE_MASK_FLAG_DDEWAIT or SEE_MASK_FLAG_NO_UI;
  sei.lpVerb := 'runas';
  sei.lpFile := PAnsiChar(Path);
  sei.lpParameters := PAnsiChar(Params);
  sei.nShow := SW_HIDE;//SW_SHOWNORMAL;
  Result := ShellExecuteExA(@sei);
  if not Result then
    RaiseLastOSError;
end;
{$endif}

procedure TfrmServiceControl.SetAutoStart(bRegister: Boolean);
{$ifdef USE_REGISTRY}
// only works with UAC Disable and always Admin
const RegKey = '\SOFTWARE\Microsoft\Windows\CurrentVersion\Run';
var Registry: TRegistry;
begin
  Registry := TRegistry.Create;
  try
//    Registry.RootKey := HKEY_CURRENT_USER;
    Registry.RootKey := HKEY_LOCAL_MACHINE;
    if Registry.OpenKey(RegKey, False) then
    begin
      if bRegister = False then
        Registry.DeleteValue(ChangeFileExt(ExtractFileName(ParamStr(0)), ''))
      else
        Registry.WriteString(ChangeFileExt(ExtractFileName(ParamStr(0)), ''), '"'+ParamStr(0)+'"');
    end;
  finally
    Registry.Free;
  end;
end;
{$else}
var
  TS: ITaskService;
  TaskFolder: ITaskFolder;
  TaskDefinition: ITaskDefinition;
  RegInfo: IRegistrationInfo;
  Principal: IPrincipal;
  TaskSettings: ITaskSettings;
  Triggers: ITriggerCollection;
  Trigger: ITrigger;
  Exec: IAction;
begin
  TS := CoTaskScheduler.Create;
  TS.Connect(null, null, null, null);
  TaskFolder := TS.GetFolder('\');

  if (bRegister) then
  begin
    TaskDefinition := TS.NewTask(0);

    RegInfo := TaskDefinition.RegistrationInfo;
    RegInfo.Description := 'Service Control Task';
    RegInfo.Author := 'Udo Schmal';

    Principal := TaskDefinition.Principal;
    Principal.Id := 'Author';
    Principal.RunLevel := TASK_RUNLEVEL_HIGHEST;

    Triggers := TaskDefinition.Triggers;
    Trigger := Triggers.Create(TASK_TRIGGER_LOGON);
    Trigger.StartBoundary := FormatDateTime('yyyy"-"mm"-"dd"T"hh":"nn":"ss', Now);
//    Trigger.EndBoundary := '2100-01-01T00:00:00';
//    Trigger.ExecutionTimeLimit := 'PT72H';
    Trigger.Id := 'AnyLogon';
    Trigger.Enabled := true;

    TaskSettings := TaskDefinition.Settings;
    TaskSettings.MultipleInstances := TASK_INSTANCES_IGNORE_NEW;
    TaskSettings.DisallowStartIfOnBatteries := false;
    TaskSettings.StopIfGoingOnBatteries := false;
    TaskSettings.AllowHardTerminate := true;
    TaskSettings.StartWhenAvailable := true;
    TaskSettings.RunOnlyIfNetworkAvailable := false;
    TaskSettings.IdleSettings.StopOnIdleEnd := false;
    TaskSettings.IdleSettings.RestartOnIdle := false;
    TaskSettings.AllowDemandStart := true;
    TaskSettings.Enabled := true;
    TaskSettings.Hidden := false;
    TaskSettings.RunOnlyIfIdle := false;
    TaskSettings.WakeToRun := false;
    TaskSettings.ExecutionTimeLimit := 'PT0S';
    TaskSettings.Priority := 7;

    TaskDefinition.Actions.Context := 'Author';
    Exec := TaskDefinition.Actions.Create(0);
    IExecAction(Exec).Id := 'Action';
    IExecAction(Exec).Path := ParamStr(0);
    IExecAction(Exec).Arguments := '';
    IExecAction(Exec).WorkingDirectory := ExtractFilePath(ParamStr(0));
    TaskFolder.RegisterTaskDefinition('Service Starter', TaskDefinition,
      TASK_CREATE_OR_UPDATE, NULL, NULL, TASK_LOGON_INTERACTIVE_TOKEN, NULL);
  end
  else
    TaskFolder.DeleteTask('Service Starter', 0);
end;
{$endif}

procedure TfrmServiceControl.UpdateServiceStatus();
var
  Services: TServiceManager;
  ServiceStatus: TServiceStatus;
begin
  FServiceIsInstalled := false;
  FServiceIsRunning := false;
  Services := TServiceManager.Create(nil);
  try
    try
//      Services.Acces := SC_MANAGER_CONNECT;
      Services.Connect;
      Services.GetServiceStatus(ServiceName, ServiceStatus);
      FServiceIsInstalled := ServiceStatus.dwCurrentState <> 0;
      FServiceIsRunning := ServiceStatus.dwCurrentState = SERVICE_RUNNING;
      Services.Disconnect;
      if FServiceIsRunning then
        TrayIcon.Hint := ServiceTitel + #10'status: running'
      else if FServiceIsInstalled then
        TrayIcon.Hint := ServiceTitel + #10'status: installed'
      else
        TrayIcon.Hint := ServiceTitel + #10'status: not installed';
    except
      on E: Exception do
      begin
        FServiceIsInstalled := false;
        FServiceIsRunning := false;
      end;
    end;
  finally
    Services.Free;
  end;
  TrayMenu.Items[0].Visible := not FServiceIsInstalled; //install
  TrayMenu.Items[1].Visible := FServiceIsInstalled and not FServiceIsRunning; //start
  TrayMenu.Items[2].Visible := FServiceIsInstalled and FServiceIsRunning; //stop
  TrayMenu.Items[3].Visible := FServiceIsInstalled and not FServiceIsRunning; //uninstall
  TrayMenu.Items[4].Visible := not FServiceIsInstalled; //leave
end;

procedure TfrmServiceControl.FormCloseQuery(Sender: TObject; var CanClose: boolean);
begin
  UpdateServiceStatus();
  WindowState := wsMinimized;
  Hide;
  CanClose := not FServiceIsInstalled;
end;

procedure TfrmServiceControl.FormCreate(Sender: TObject);
begin
  WindowState := wsMinimized;
  Hide;
  TrayIcon.Hint := ServiceTitel;
  TrayIcon.BalloonTitle := ServiceTitel;
  FPath := ExtractFilePath(ParamStr(0));
end;

procedure TfrmServiceControl.TrayMenuPopup(Sender: TObject);
begin
  UpdateServiceStatus();
end;

procedure TfrmServiceControl.startClick(Sender: TObject);
var Services: TServiceManager;
begin
  Services := TServiceManager.Create(nil);
  try
//    Services.Acces := SC_MANAGER_ALL_ACCESS;
    Services.Connect;
    Services.StartService(ServiceName, nil);
    Services.Disconnect;
  finally
    Services.Free;
  end;
  UpdateServiceStatus();
end;

procedure TfrmServiceControl.stopClick(Sender: TObject);
var Services: TServiceManager;
begin
  Services := TServiceManager.Create(nil);
  try
//    Services.Acces := SC_MANAGER_ALL_ACCESS;
    Services.Connect;
    Services.StopService(ServiceName, true);
    Services.Disconnect;
  finally
    Services.Free;
  end;
  UpdateServiceStatus();
end;

procedure TfrmServiceControl.TrayIconMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  UpdateServiceStatus();
end;

procedure TfrmServiceControl.installClick(Sender: TObject);
{$ifdef USE_SHELLAPI}
begin
RunAsAdmin(self.Handle, FPath + ServiceExecutable, '--install');
{$else}
var AProcess: TProcess;
begin
  AProcess := TProcess.Create(nil);
  AProcess.Executable := FPath + ServiceExecutable;
  AProcess.Parameters.Add('--install');
  AProcess.Options := [poWaitOnExit];
  AProcess.Execute;
  AProcess.Free;
{$endif}
  UpdateServiceStatus();
  SetAutoStart(true);
end;

procedure TfrmServiceControl.uninstallClick(Sender: TObject);
{$ifdef USE_SHELLAPI}
begin
  RunAsAdmin(self.Handle, FPath + ServiceExecutable, '--uninstall');
{$else}
var AProcess: TProcess;
begin
  AProcess := TProcess.Create(nil);
  AProcess.Executable := FPath + ServiceExecutable;
  AProcess.Parameters.Add('--uninstall');
  AProcess.Options := [poWaitOnExit];
  AProcess.Execute;
  AProcess.Free;
{$endif}
  UpdateServiceStatus();
  SetAutoStart(false);
end;


procedure TfrmServiceControl.leaveClick(Sender: TObject);
begin
  Close;
end;

end.

The Complete Project:

ServiceControl.zip (56,03 kByte) 26.10.2015 00:14

Autor: , veröffentlicht: , letzte Änderung:

Kontakt

Copyright / License of sources

Copyright (c) 2007-2017, Udo Schmal <udo.schmal@t-online.de>

Permission to use, copy, modify, and/or distribute the software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies.

THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

Service Infos

CMS Info
UDOs Webserver

0.3.1.24

All in one Webserver

Udo Schmal

Sa, 21 Okt 2017 00:30:10
Development Info
Lazarus LCL 1.9.0.0

Free Pascal FPC 3.1.1

OS:Win64, CPU:x86_64
Hardware Info
Precision WorkStation T3500

Intel(R) Xeon(R) CPU W3530 @ 2.80GHz

x86_64, 1 physical CPU(s), 4 Core(s), 8 logical CPU(s), 2800 MHz