jclsvcctrl.pas

East make Tray Icon in delphi

  if AutoAdd then
  begin
    SvcGrp := TJclServiceGroup.Create(Self, GrpName, GetGroupCount);
    AddGroup(SvcGrp);
  end
  else
    SvcGrp := nil;
end;

function TJclSCManager.GetServiceLockStatus: PQueryServiceLockStatus;
var
  Ret: BOOL;
  BytesNeeded: DWORD;
begin
  Assert((DesiredAccess and SC_MANAGER_QUERY_LOCK_STATUS) <> 0);
  Active := True;

  try
    Result := nil;
    BytesNeeded := 10240;
    repeat
      ReallocMem(Result, BytesNeeded);
      Ret := QueryServiceLockStatus(FHandle, Result{$IFNDEF FPC}^{$ENDIF FPC}, BytesNeeded, BytesNeeded);
    until Ret or (GetLastError <> ERROR_INSUFFICIENT_BUFFER);
    Win32Check(Ret);
  except
    FreeMem(Result);
    raise;
  end;
end;

function TJclSCManager.IsLocked: Boolean;
var
  PQsls: PQueryServiceLockStatus;
begin
  PQsls := GetServiceLockStatus;
  Result := Assigned(PQsls) and (PQsls.fIsLocked <> 0);
  FreeMem(PQsls);
end;

function TJclSCManager.LockOwner: string;
var
  PQsls: PQueryServiceLockStatus;
begin
  PQsls := GetServiceLockStatus;
  if Assigned(PQsls) then
    Result := PQsls.lpLockOwner
  else
    Result := '';
  FreeMem(PQsls);
end;

function TJclSCManager.LockDuration: DWORD;
var
  PQsls: PQueryServiceLockStatus;
begin
  PQsls := GetServiceLockStatus;
  if Assigned(PQsls) then
    Result := PQsls.dwLockDuration
  else
    Result := INFINITE;
  FreeMem(PQsls);
end;

function TJclSCManager.GetAdvApi32Handle: TModuleHandle;
const
  cAdvApi32 = 'advapi32.dll'; // don't localize
begin
  if FAdvApi32Handle = INVALID_MODULEHANDLE_VALUE then
    LoadModule(FAdvApi32Handle, cAdvApi32);
  Result := FAdvApi32Handle;
end;

{ TODO : Standard Rtdl }
function TJclSCManager.GetQueryServiceConfig2A: TQueryServiceConfig2A;
const
  cQueryServiceConfig2 = 'QueryServiceConfig2A'; // don't localize
begin
  // Win2K or later
  if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion >= 5) then
    FQueryServiceConfig2A := GetModuleSymbol(AdvApi32Handle, cQueryServiceConfig2);

  Result := FQueryServiceConfig2A;
end;

function TJclSCManager.Install(const ServiceName, DisplayName, ImageName, Description: string;
  ServiceTypes: TJclServiceTypes; StartType: TJclServiceStartType;
  ErrorControlType: TJclServiceErrorControlType; DesiredAccess: DWORD;
  const LoadOrderGroup: TJclServiceGroup;
  const Dependencies, Account, Password: PChar): TJclNtService;
var
  LoadOrderGroupName: string;
  LoadOrderGroupNamePtr: PChar;
  EnumServiceStatus: TEnumServiceStatus;
  Svc: THandle;
begin
  if Assigned(LoadOrderGroup) then
  begin
    LoadOrderGroupName := LoadOrderGroup.Name;
    LoadOrderGroupNamePtr := PChar(LoadOrderGroupName);
  end
  else
  begin
    LoadOrderGroupName := '';
    LoadOrderGroupNamePtr := nil;
  end;

  Svc := CreateService(FHandle, PChar(ServiceName), PChar(DisplayName),
    DesiredAccess, TJclSCManager.ServiceType(ServiceTypes), DWORD(StartType),
    DWORD(ErrorControlType), PChar(ImageName), LoadOrderGroupNamePtr, nil,
    Dependencies, Account, Password);
  if Svc = 0 then
    RaiseLastOsError;
  CloseServiceHandle(Svc);

  if (Description <> '') and (IsWin2K or IsWinXP) then
    RegWriteString(HKEY_LOCAL_MACHINE, '\' + REGSTR_PATH_SERVICES + '\' + ServiceName,
      'Description', Description);

  EnumServiceStatus.lpServiceName := PChar(ServiceName);
  EnumServiceStatus.lpDisplayName := PChar(DisplayName);

  Result := TJclNtService.Create(Self, EnumServiceStatus);
  Result.Refresh;
end;

class function TJclSCManager.ServiceType(const SvcType: TJclServiceTypes): DWORD;
var
  AType: TJclServiceType;
begin
  Result := 0;
  for AType := Low(TJclServiceType) to High(TJclServiceType) do
    if AType in SvcType then
      Result := Result or ServiceTypeMapping[AType];
end;

class function TJclSCManager.ServiceType(const SvcType: DWORD): TJclServiceTypes;
var
  AType: TJclServiceType;
begin
  Result := [];
  for AType := Low(TJclServiceType) to High(TJclServiceType) do
    if (SvcType and ServiceTypeMapping[AType]) <> 0 then
      Include(Result, AType);
end;

class function TJclSCManager.ControlAccepted(const CtrlAccepted: TJclServiceControlAccepteds): DWORD;
var
  ACtrl: TJclServiceControlAccepted;
begin
  Result := 0;
  for ACtrl := Low(TJclServiceControlAccepted) to High(TJclServiceControlAccepted) do
    if ACtrl in CtrlAccepted then
      Result := Result or ServiceControlAcceptedMapping[ACtrl];
end;

class function TJclSCManager.ControlAccepted(const CtrlAccepted: DWORD): TJclServiceControlAccepteds;
var
  ACtrl: TJclServiceControlAccepted;
begin
  Result := [];
  for ACtrl := Low(TJclServiceControlAccepted) to High(TJclServiceControlAccepted) do
    if (CtrlAccepted and ServiceControlAcceptedMapping[ACtrl]) <> 0 then
      Include(Result, ACtrl);
end;

function GetServiceStatusByName(const AServer,AServiceName:string):TJclServiceState;
var
  ServiceHandle,
  SCMHandle: DWORD;
  SCMAccess,Access:DWORD;
  ServiceStatus: TServiceStatus;
begin
  Result:=ssUnknown;

  SCMAccess:=SC_MANAGER_CONNECT or SC_MANAGER_ENUMERATE_SERVICE or SC_MANAGER_QUERY_LOCK_STATUS;
  Access:=SERVICE_INTERROGATE or GENERIC_READ;

  SCMHandle:= OpenSCManager(PChar(AServer), Nil, SCMAccess);
  if SCMHandle <> 0 then
  try
    ServiceHandle:=OpenService(SCMHandle,PChar(AServiceName),Access);
    if ServiceHandle <> 0 then
    try
      if QueryServiceStatus(ServiceHandle,ServiceStatus) then
        Result:=TJclServiceState(ServiceStatus.dwCurrentState);
    finally
      CloseServiceHandle(ServiceHandle);
    end;
  finally
    CloseServiceHandle(SCMHandle);
  end;
end;

function StartServiceByName(const AServer,AServiceName: String):Boolean;
var
  ServiceHandle,
  SCMHandle: DWORD;
  p: PChar;
begin
  p:=nil;
  Result:=False;

  SCMHandle:= OpenSCManager(PChar(AServer), nil, SC_MANAGER_ALL_ACCESS);
  if SCMHandle <> 0 then
  try
    ServiceHandle:=OpenService(SCMHandle,PChar(AServiceName),SERVICE_ALL_ACCESS);
    if ServiceHandle <> 0 then
      Result:=StartService(ServiceHandle,0,p);

    CloseServiceHandle(ServiceHandle);
  finally
    CloseServiceHandle(SCMHandle);
  end;
end;

function StopServiceByName(const AServer, AServiceName: String):Boolean;
var
  ServiceHandle,
  SCMHandle: DWORD;
  SS: _Service_Status;
begin
  Result:=False;

  SCMHandle:= OpenSCManager(PChar(AServer), nil, SC_MANAGER_ALL_ACCESS);
  if SCMHandle <> 0 then
  try
    ServiceHandle:=OpenService(SCMHandle,PChar(AServiceName),SERVICE_ALL_ACCESS);
    if ServiceHandle <> 0 then
      Result:=ControlService(ServiceHandle,SERVICE_CONTROL_STOP,SS);

    CloseServiceHandle(ServiceHandle);
  finally
    CloseServiceHandle(SCMHandle);
  end;
end;

function GetServiceStatus(ServiceHandle: SC_HANDLE): DWORD;
var
  ServiceStatus: TServiceStatus;
begin
  if not QueryServiceStatus(ServiceHandle, ServiceStatus) then
    RaiseLastOSError;

  Result := ServiceStatus.dwCurrentState;
end;

function GetServiceStatusWaitingIfPending(ServiceHandle: SC_HANDLE): DWORD;
var
  ServiceStatus: TServiceStatus;
  WaitDuration: DWORD;
  LastCheckPoint: DWORD;
begin
  if not QueryServiceStatus(ServiceHandle, ServiceStatus) then
    RaiseLastOSError;

  Result := ServiceStatus.dwCurrentState;

  while TJclServiceState(Result) in ssPendingStates do
  begin
    LastCheckPoint := ServiceStatus.dwCheckPoint;

    // Multiple operations might alter the expected wait duration, so check inside the loop
    WaitDuration := ServiceStatus.dwWaitHint;
    if WaitDuration < 1000 then
      WaitDuration := 1000
    else
    if WaitDuration > 10000 then
      WaitDuration := 10000;

    Sleep(WaitDuration);

    // Get the new status
    if not QueryServiceStatus(ServiceHandle, ServiceStatus) then
      RaiseLastOSError;

    Result := ServiceStatus.dwCurrentState;

    if ServiceStatus.dwCheckPoint = LastCheckPoint then  // No progress made
      Break;
  end;
end;

// History:

// $Log: JclSvcCtrl.pas,v $
// Revision 1.32  2005/02/25 07:20:16  marquardt
// add section lines
//
// Revision 1.31  2005/02/24 16:34:52  marquardt
// remove divider lines, add section lines (unfinished)
//
// Revision 1.30  2004/12/22 09:21:32  rrossmair
// - removed superfluous comma in line 746 (which D7's parser did tolerate, but those of D5 and D6 did not)
//
// Revision 1.29  2004/12/21 12:24:51  rikbarker
// Added code by Warren Postma to allow modification of service start type. (Disabled, Automatic etc)
// Added three new helper functions,
//    GetServiceStatusByName
//    StartServiceByName
//    StopServiceByName
//
// Revision 1.28  2004/10/24 01:36:26  mthoma
// history cleaned.
//
// Revision 1.27  2004/10/21 08:40:11  marquardt
// style cleaning
//
// Revision 1.26  2004/10/21 06:38:53  marquardt
// style clenaing, bugfixes, improvements
//
// Revision 1.25  2004/10/20 09:35:06  rikbarker
// EnumServiceGroups Modified to use new JclRegistry MULTI_SZ enabled functions.
// PH cleaning of GetServiceStatus.
// GetServiceStatusWaitingIfPending rewritten
// New set ssPendingStates defined
//
// Revision 1.24  2004/10/17 21:00:16  mthoma
// cleaning
//
// Revision 1.23  2004/10/11 08:13:04  marquardt
// PH cleaning of JclStrings
//
// Revision 1.22  2004/07/29 07:58:22  marquardt
// inc files updated
//
// Revision 1.21  2004/07/28 18:00:54  marquardt
// various style cleanings, some minor fixes
//
// Revision 1.20  2004/06/16 07:30:31  marquardt
// added tilde to all IFNDEF ENDIFs, inherited qualified
//
// Revision 1.19  2004/06/14 13:05:21  marquardt
// style cleaning ENDIF, Tabs
//
// Revision 1.18  2004/06/14 11:05:53  marquardt
// symbols added to all ENDIFs and some other minor style changes like removing IFOPT
//
// Revision 1.17  2004/06/02 03:23:47  rrossmair
// cosmetic changes in several units (code formatting, help TODOs processed etc.)
//
// Revision 1.16  2004/05/13 07:46:06  rrossmair
// changes for FPC 1.9.3+ compatibility
//
// Revision 1.15  2004/05/06 23:41:33  rrossmair
// fix: $IFDEF FPC left empty const section
//
// Revision 1.14  2004/05/06 22:37:10  rrossmair
// contributor list updated
//
// Revision 1.13  2004/05/06 22:29:19  rrossmair
// Changes for FPC v1.9.4 compatibility
//
// Revision 1.12  2004/05/05 07:33:49  rrossmair
// header updated according to new policy: initial developers & contributors listed
//
// Revision 1.11  2004/04/26 04:25:46
// - add GetServiceStatus
// - add GetServiceStatusWaitingIfPending
//
// Revision 1.10  2004/04/12 22:04:38
// Bugfix: TJclSCManager.Refresh EnumServiceGroups
//
// Revision 1.9  2004/04/08 19:49:26  mthoma
// Fixed 0000521, 0000848. Range check error in TJclSCManager.Refresh and TJclSCManager raises exception when free'd .
//
// Revision 1.8  2004/04/08 12:18:07  obones
// BCB5 compatibility fix
//
// Revision 1.7  2004/04/08 02:44:52  rrossmair
// Log clean-up, typo in $Date: 2005/02/25 07:20:16 $ corrected
//
// Revision 1.6  2004/04/07 18:43:02
//
// Revision 1.5  2004/04/07 14:01:15  obones
//
// Revision 1.4  2004/04/06 04:55:18
// adapt compiler conditions, add log entry
//

end.