jclsvcctrl.pas

East make Tray Icon in delphi

    WaitFor(ssRunning);
end;

function TJclNtService.WaitFor(const State: TJclServiceState; const TimeOut: DWORD): Boolean;
var
  SvcStatus: TServiceStatus;
  WaitedState, StartTickCount, OldCheckPoint, WaitTime: DWORD;
begin
  WaitedState := DWORD(State);
  Open(SERVICE_QUERY_STATUS);
  try
    StartTickCount := GetTickCount;
    OldCheckPoint := 0;
    while True do
    begin
      SvcStatus := GetServiceStatus;
      if SvcStatus.dwCurrentState = WaitedState then
        Break;
      if SvcStatus.dwCheckPoint > OldCheckPoint then
      begin
        StartTickCount := GetTickCount;
        OldCheckPoint := SvcStatus.dwCheckPoint;
      end
      else
      begin
        if TimeOut <> INFINITE then
          { TODO : Do we need to disable RangeCheck? }
          if (GetTickCount - StartTickCount) > Max(SvcStatus.dwWaitHint, TimeOut) then
            Break;
      end;
      WaitTime := SvcStatus.dwWaitHint div 10;
      if WaitTime < 1000 then
        WaitTime := 1000
      else
      if WaitTime > 10000 then
        WaitTime := 10000;
      Sleep(WaitTime);
    end;
    Result := SvcStatus.dwCurrentState = WaitedState;
  finally
    Close;
  end;
end;

//=== { TJclServiceGroup } ===================================================

constructor TJclServiceGroup.Create(const ASCManager: TJclSCManager;
  const AName: string; const AOrder: Integer);
begin
  Assert(Assigned(ASCManager));
  inherited Create;
  FSCManager := ASCManager;
  FName := AName;
  if FName <> '' then
    FOrder := AOrder
  else
    FOrder := MaxInt;
  FServices := TList.Create;
end;

destructor TJclServiceGroup.Destroy;
begin
  FreeAndNil(FServices);
  inherited Destroy;
end;

function TJclServiceGroup.Add(const AService: TJclNtService): Integer;
begin
  Result := FServices.Add(AService);
end;

function TJclServiceGroup.Remove(const AService: TJclNtService): Integer;
begin
  Result := FServices.Remove(AService);
end;

function TJclServiceGroup.GetService(const Idx: Integer): TJclNtService;
begin
  Result := TJclNtService(FServices.Items[Idx]);
end;

function TJclServiceGroup.GetServiceCount: Integer;
begin
  Result := FServices.Count;
end;

//=== { TJclSCManager } ======================================================

constructor TJclSCManager.Create(const AMachineName: string;
  const ADesiredAccess: DWORD; const ADatabaseName: string);
begin
  Assert((ADesiredAccess and (not SC_MANAGER_ALL_ACCESS)) = 0);
  inherited Create;
  FMachineName := AMachineName;
  FDatabaseName := ADatabaseName;
  FDesiredAccess := ADesiredAccess;
  FHandle := INVALID_SCM_HANDLE;
  FServices := TObjectList.Create;
  FGroups := TObjectList.Create;
  FOrderType := sotServiceName;
  FOrderAsc := True;
  FAdvApi32Handle := INVALID_MODULEHANDLE_VALUE;
  FQueryServiceConfig2A := nil;
end;

destructor TJclSCManager.Destroy;
begin
  FreeAndNil(FGroups);
  FreeAndNil(FServices);
  Close;
  UnloadModule(FAdvApi32Handle);
  inherited Destroy;
end;

function TJclSCManager.AddService(const AService: TJclNtService): Integer;
begin
  Result := FServices.Add(AService);
end;

function TJclSCManager.GetService(const Idx: Integer): TJclNtService;
begin
  Result := TJclNtService(FServices.Items[Idx]);
end;

function TJclSCManager.GetServiceCount: Integer;
begin
  Result := FServices.Count;
end;

function TJclSCManager.AddGroup(const AGroup: TJclServiceGroup): Integer;
begin
  Result := FGroups.Add(AGroup);
end;

function TJclSCManager.GetGroup(const Idx: Integer): TJclServiceGroup;
begin
  Result := TJclServiceGroup(FGroups.Items[Idx]);
end;

function TJclSCManager.GetGroupCount: Integer;
begin
  Result := FGroups.Count;
end;

procedure TJclSCManager.SetOrderAsc(const Value: Boolean);
begin
  if FOrderAsc <> Value then
    Sort(OrderType, Value);
end;

procedure TJclSCManager.SetOrderType(const Value: TJclServiceSortOrderType);
begin
  if FOrderType <> Value then
    Sort(Value, FOrderAsc);
end;

function TJclSCManager.GetActive: Boolean;
begin
  Result := FHandle <> INVALID_SCM_HANDLE;
end;

procedure TJclSCManager.SetActive(const Value: Boolean);
begin
  if Value <> GetActive then
  begin
    if Value then
      Open
    else
      Close;
    Assert(Value = GetActive);
  end;
end;

procedure TJclSCManager.Open;
begin
  if not Active then
  begin
    FHandle := OpenSCManager(Pointer(FMachineName), Pointer(FDatabaseName), FDesiredAccess);
    Win32Check(FHandle <> INVALID_SCM_HANDLE);
  end;
end;

procedure TJclSCManager.Close;
begin
  if Active then
    Win32Check(CloseServiceHandle(FHandle));
  FHandle := INVALID_SCM_HANDLE;
end;

procedure TJclSCManager.Lock;
begin
  Assert((DesiredAccess and SC_MANAGER_LOCK) <> 0);
  Active := True;
  FLock := LockServiceDatabase(FHandle);
  Win32Check(FLock <> nil);
end;

procedure TJclSCManager.Unlock;
begin
  Assert(Active);
  Assert((DesiredAccess and SC_MANAGER_LOCK) <> 0);
  Assert(FLock <> nil);
  Win32Check(UnlockServiceDatabase(FLock));
end;

procedure TJclSCManager.Clear;
begin
  FServices.Clear;
  FGroups.Clear;
end;

procedure TJclSCManager.Refresh(const RefreshAll: Boolean);

  procedure EnumServices;
  var
    I: Integer;
    Ret: BOOL;
    PBuf: Pointer;
    PEss: PEnumServiceStatus;
    NtSvc: TJclNtService;
    BytesNeeded, ServicesReturned, ResumeHandle: DWORD;
  begin
    Assert((DesiredAccess and SC_MANAGER_ENUMERATE_SERVICE) <> 0);
    // Enum the services
    ResumeHandle := 0; // Must set this value to zero !!!
    try
      PBuf := nil;
      BytesNeeded := 40960;
      repeat
        ReallocMem(PBuf, BytesNeeded);
        Ret := EnumServicesStatus(FHandle, SERVICE_TYPE_ALL, SERVICE_STATE_ALL,
          PEnumServiceStatus(PBuf){$IFNDEF FPC}^{$ENDIF},
          BytesNeeded, BytesNeeded, ServicesReturned, ResumeHandle);
      until Ret or (GetLastError <> ERROR_MORE_DATA);
      Win32Check(Ret);

      PEss := PBuf;
      for I := 0 to ServicesReturned - 1 do
      begin
        NtSvc := TJclNtService.Create(Self, PEss^);
        NtSvc.Refresh;
        Inc(PEss);
      end;
    finally
      FreeMem(PBuf);
    end;
  end;

  { TODO : Delete after Test }
  {procedure EnumServiceGroups;
  const
    cKeyServiceGroupOrder = 'SYSTEM\CurrentControlSet\Control\ServiceGroupOrder';
    cValList              = 'List';
  var
    Buf: array of Char;
    P: PChar;
    DataSize: DWORD;
  begin
    // Get the service groups
    DataSize := RegReadBinary(HKEY_LOCAL_MACHINE, cKeyServiceGroupOrder, cValList, PChar(nil)^, 0);
    SetLength(Buf, DataSize);
    if DataSize > 0 then
    begin
      DataSize := RegReadBinary(HKEY_LOCAL_MACHINE, cKeyServiceGroupOrder, cValList, Buf[0], DataSize);

      P := @Buf[0];
      while P^ <> #0 do
      begin
        AddGroup(TJclServiceGroup.Create(Self, P, GetGroupCount));
        Inc(P, StrLen(P) + 1);
      end;
    end;
  end;}

  { TODO -cTest : Test, if OK delete function above }
  { TODO -cHelp : }
  procedure EnumServiceGroups;
  const
    cKeyServiceGroupOrder = 'SYSTEM\CurrentControlSet\Control\ServiceGroupOrder';
    cValList = 'List';
  var
    List: TStringList;
    I: Integer;
  begin
    // Get the service groups
    List := TStringList.Create;
    try
      RegReadMultiSz(HKEY_LOCAL_MACHINE, cKeyServiceGroupOrder, cValList, List);
      for I := 0 to List.Count - 1 do
        AddGroup(TJclServiceGroup.Create(Self, List[I], GetGroupCount));
    finally
      List.Free;
    end;
  end;

  procedure RefreshAllServices;
  var
    I: Integer;
  begin
    for I := 0 to GetServiceCount - 1 do
      GetService(I).Refresh;
  end;

begin
  Active := True;
  if RefreshAll then
  begin
    Clear;
    EnumServiceGroups;
    EnumServices;
  end;
  RefreshAllServices;
end;

function ServiceSortFunc(Item1, Item2: Pointer): Integer;
var
  Svc1, Svc2: TJclNtService;
begin
  Svc1 := Item1;
  Svc2 := Item2;
  case Svc1.SCManager.FOrderType of
    sotServiceName:
      Result := AnsiCompareStr(Svc1.ServiceName, Svc2.ServiceName);
    sotDisplayName:
      Result := AnsiCompareStr(Svc1.DisplayName, Svc2.DisplayName);
    sotDescription:
      Result := AnsiCompareStr(Svc1.Description, Svc2.Description);
    sotFileName:
      Result := AnsiCompareStr(Svc1.FileName, Svc2.FileName);
    sotServiceState:
      Result := Integer(Svc1.ServiceState) - Integer(Svc2.ServiceState);
    sotStartType:
      Result := Integer(Svc1.StartType) - Integer(Svc2.StartType);
    sotErrorControlType:
      Result := Integer(Svc1.ErrorControlType) - Integer(Svc2.ErrorControlType);
    sotLoadOrderGroup:
      Result := Svc1.Group.Order - Svc2.Group.Order;
    sotWin32ExitCode:
      Result := Svc1.Win32ExitCode - Svc2.Win32ExitCode;
  else
    Result := 0;
  end;
  if not Svc1.SCManager.FOrderAsc then
    Result := -Result;
end;

procedure TJclSCManager.Sort(const AOrderType: TJclServiceSortOrderType; const AOrderAsc: Boolean);
begin
  FOrderType := AOrderType;
  FOrderAsc := AOrderAsc;
  FServices.Sort(ServiceSortFunc);
end;

function TJclSCManager.FindService(const SvcName: string; var NtSvc: TJclNtService): Boolean;
var
  I: Integer;
begin
  Result := False;
  for I := 0 to GetServiceCount - 1 do
  begin
    NtSvc := GetService(I);
    if CompareText(NtSvc.ServiceName, SvcName) = 0 then
    begin
      Result := True;
      Exit;
    end;
  end;
  NtSvc := nil;
end;

function TJclSCManager.FindGroup(const GrpName: string; var SvcGrp: TJclServiceGroup;
  const AutoAdd: Boolean): Boolean;
var
  I: Integer;
begin
  Result := False;
  for I := 0 to GetGroupCount - 1 do
  begin
    if CompareText(GetGroup(I).Name, GrpName) = 0 then
    begin
      SvcGrp := GetGroup(I);
      Result := True;
      Exit;
    end;
  end;