lina-components/Source/uSysTools.pas

unit uSysTools;

//////////////////////////////////////
///  Lina System Tools Unit        ///
///  ****************************  ///
///  (c) 2014 Dennis Göhlert a.o.  ///
//////////////////////////////////////

interface

uses
  { Standard-Units }
  SysUtils, Classes, Math, Windows, Graphics, Printers,
  {$IFNDEF NO_GENERIC}
    Generics.Collections,
  {$ENDIF}
  { Andere Package-Units }
  uBase;

type
  { Fehlermeldungen }
  EWinUserInformation = class(Exception);
  EInvalidValueType = class(Exception);

type
  { Hilfsklassen }
  TStringFilterMode = (sfmAnyPosition,sfmBeginning);
  TStringFilterOptions = set of (sfoCaseSensitive,sfoForceTrim,sfoDefaultVisible);

type
  {$IFNDEF NO_GENERIC}
    TVariantList = TList<Variant>;
    TIntegerList = TList<Integer>;
    TBooleanList = TList<Boolean>;
    TFloatList = TList<Extended>;
    TPointList = TList<TPoint>;
  {$ENDIF}
  TVariantArray = array of Variant;
  TIntegerArray = array of Integer;
  TBooleanArray = array of Boolean;
  TFloatArray = array of Extended;
  TPointArray = array of TPoint;

  TFilteredStringList = class(TStringList)
  private
    { Private-Deklarationen }
    FFiltered: Boolean;
    FFilter: String;
    FFilteredStrings: TStrings;
    FFilterMode: TStringFilterMode;
    FFilterOptions: TStringFilterOptions;
    { Methoden }
    function GetFilteredStrings: TStrings;
  protected
    { Protected-Deklarationen }
    procedure FilterUpdate;
  public
    { Public-Deklarationen }
    constructor Create;
    destructor Destroy; override;
    property Filtered: Boolean read FFiltered write FFiltered default True;
    property Filter: String read FFilter write FFilter;
    property FilteredStrings: TStrings read GetFilteredStrings;
    property FilterMode: TStringFilterMode read FFilterMode write FFilterMode default sfmBeginning;
    property FilterOptions: TStringFilterOptions read FFilterOptions write FFilterOptions default [sfoCaseSensitive,sfoForceTrim,sfoDefaultVisible];
  end;

  { Typenumwandelungen }
  function BoolToInt(B: Boolean): Integer;
  function IntToBool(Value: Integer): Boolean;
  { Typen-Äquivalenz-Prüfungen }
  function StrIsInt(const S: String): Boolean;
  function StrIsFloat(const S: String): Boolean;
  function StrIsBool(const S: String): Boolean;
  function FloatIsInt(Value: Extended): Boolean;
  { WinUser }
  function WinUserName: String;
  function WinUserDirectory: String;
  function WinUserAdmin: Boolean;
  function WinUserExists(UsrNme: String): Boolean;
  { Array-Position }
  function ArrayPos(const AValue: Variant; const AArray: array of Variant): Integer; overload;
  function ArrayPos(const AValue: Char; const AArray: array of Char): Integer; overload;
  function ArrayPos(const AValue: String; const AArray: array of String): Integer; overload;
  function ArrayPos(const AValue: Integer; const AArray: array of Integer): Integer; overload;
  function ArrayPos(const AValue: Extended; const AArray: array of Extended): Integer; overload;
  { TComponent Laden/Speichern }
  procedure SaveComponentToFile(const FileName: String; Component: TComponent);
  procedure LoadComponentFromFile(const FileName: String; Component: TComponent);
  procedure SaveComponentToStream(var Stream: TStream; Component: TComponent);
  procedure LoadComponentFromStream(Stream: TStream; Component: TComponent);
  { Char-Case-Umwandelungen }
  function CharLowerCase(Character: Char): Char;
  function CharUpperCase(Character: Char): Char;
  { Sonstige }
  function SecToTime(const Sec: Cardinal): TTime;
  function SystemLanguage: String;
  function ExtractUserName(const Owner: String): String;
  function ExtractUserDomain(const Owner: String): String;
  function RoundPos(Number: Extended; Pos: Byte): Extended;
  function FontSizeToHeight(Size: Integer; PpI: Integer): Integer;
  function FontHeightToSize(Height: Integer; PpI: Integer): Integer;
  procedure PrintText(Strings: TStrings; Font: TFont);
  procedure EnableDebugPrivilege;

const
  Spaces = [#9,#10,#13,#32,#160];
  SE_DEBUG_NAME = 'SeDebugPrivilege';

implementation

uses
  uFileTools;

function BoolToInt(B: Boolean): Integer;
begin
  if B then
  begin
    Result := not 0;
  end else
  begin
    Result := 0;
  end;
end;

function IntToBool(Value: Integer): Boolean;
begin
  Result := (Value <> 0);
end;

function StrIsInt(const S: String): Boolean;
var
  TryMethodBuffer: Integer;
begin
  Result := TryStrToInt(S,TryMethodBuffer);
end;

function StrIsFloat(const S: String): Boolean;
var
  TryMethodBuffer: Extended;
begin
  Result := TryStrToFloat(S,TryMethodBuffer);
end;

function StrIsBool(const S: String): Boolean;
var
  TryMethodBuffer: Boolean;
begin
  Result := TryStrToBool(S,TryMethodBuffer);
end;

function FloatIsInt(Value: Extended): Boolean;
begin
  Result := (Ceil(Value) = Floor(Value));
end;

procedure SaveComponentToFile(const FileName: String; Component: TComponent);
var
  FS: TFileStream;
begin
  FS := TFileStream.Create(FileName,fmCreate);
  try
    FS.WriteComponentRes(Component.Name,Component);
  finally
    FS.Free;
  end;
end;

procedure LoadComponentFromFile(const FileName: String; Component: TComponent);
var
  FS: TFileStream;
begin
  FS := TFileStream.Create(FileName,fmOpenRead or fmShareDenyNone);
  try
    FS.ReadComponentRes(Component);
  finally
    FS.Free;
  end;
end;

procedure SaveComponentToStream(var Stream: TStream; Component: TComponent);
begin
  Stream.WriteComponentRes(Component.Name,Component);
end;

procedure LoadComponentFromStream(Stream: TStream; Component: TComponent);
begin
  Stream.ReadComponentRes(Component);
end;

function CharLowerCase(Character: Char): Char;
{ Basierend auf der Technik von SysUtils.LowerCase, nur simpler/schneller }
begin
  if Character in ['A'..'Z'] then
  begin
    Result := Char(Word(Character) or $0020);
  end else
  begin
    Result := Character;
  end;
end;

function CharUpperCase(Character: Char): Char;
{ Basierend auf der Technik von SysUtils.UpperCase, nur simpler/schneller }
begin
  if Character in ['a'..'z'] then
  begin
    Result := Char(Word(Character) xor $0020);
  end else
  begin
    Result := Character;
  end;
end;

function SecToTime(const Sec: Cardinal): TTime;
var
   TH, TM, TS: String;
   SH, SM, SS: Integer;
begin
  if Sec <= 0 then
  begin
    Result := StrToTime('00:00:00');
    Exit;
  end;
  SH := Sec div 3600;
  SM := Sec div 60 - SH * 60;
  SS := Sec - (SH * 3600 + SM * 60) ;
  TH := IntToStr(SH);
  TM := IntToStr(SM);
  TS := IntToStr(SS);
  Result := StrToTime(TH + ':' + TM + ':' + TS);
end;

function SystemLanguage: String;
begin
  Result := Languages.NameFromLocaleID[Languages.UserDefaultLocale];
end;

function ArrayPos(const AValue: Variant; const AArray: array of Variant): Integer; overload;
{ Da diese Funktion als Parametertyp Variants verwendet, wird von der Verwendung
  bei komplexeren Abläufen aufgrund der geringen Performance varianter Typen
  ausdrücklich abgeraten! }
var
  Index: Integer;
begin
  Result := Low(AArray) - 1;
  for Index := Low(AArray) to High(AArray) do
  begin
    if AArray[Index] = AValue then
    begin
      Result := Index;
      Exit;
    end;
  end;
end;

function ArrayPos(const AValue: Char; const AArray: array of Char): Integer; overload;
var
  Index: Integer;
begin
  Result := Low(AArray) - 1;
  for Index := Low(AArray) to High(AArray) do
  begin
    if AArray[Index] = AValue then
    begin
      Result := Index;
      Exit;
    end;
  end;
end;

function ArrayPos(const AValue: String; const AArray: array of String): Integer; overload;
var
  Index: Integer;
begin
  Result := Low(AArray) - 1;
  for Index := Low(AArray) to High(AArray) do
  begin
    if AArray[Index] = AValue then
    begin
      Result := Index;
      Exit;
    end;
  end;
end;

function ArrayPos(const AValue: Integer; const AArray: array of Integer): Integer; overload;
var
  Index: Integer;
begin
  Result := Low(AArray) - 1;
  for Index := Low(AArray) to High(AArray) do
  begin
    if AArray[Index] = AValue then
    begin
      Result := Index;
      Exit;
    end;
  end;
end;

function ArrayPos(const AValue: Extended; const AArray: array of Extended): Integer; overload;
var
  Index: Integer;
begin
  Result := Low(AArray) - 1;
  for Index := Low(AArray) to High(AArray) do
  begin
    if AArray[Index] = AValue then
    begin
      Result := Index;
      Exit;
    end;
  end;
end;

function ExtractUserName(const Owner: String): String;
var
  Index: Integer;
begin
  for Index := 1 to Length(Owner) do
  begin
    if Owner[Index] = '@' then
    begin
      Break;
    end else
    begin
      Result := Result + Owner[Index];
    end;
  end;
end;

function ExtractUserDomain(const Owner: String): String;
var
  Index: Integer;
begin
  for Index := Length(Owner) downto 0 do
  begin
    if Owner[Index] = '@' then
    begin
      Break;
    end else
    begin
      Result := Result + Owner[Index];
    end;
  end;
end;

function RoundPos(Number: Extended; Pos: Byte): Extended;
var
  Factor: Extended;
begin
  Factor := IntPower(10,Pos);
  Number := Round(Number * Factor);
  Result := Number / Factor;
end;

function FontSizeToHeight(Size: Integer; PpI: Integer): Integer;
begin
  Result := - Size * PpI div 72;
end;

function FontHeightToSize(Height: Integer; PpI: Integer): Integer;
begin
  Result := - Height * 72 div PpI;
end;

procedure PrintText(Strings: TStrings; Font: TFont);
var
  Index: Integer;
  PrintText: TextFile;
begin
  AssignPrn(PrintText);
  Rewrite(PrintText);
  try
    if Font = nil then
    begin
      Printer.Canvas.Font := Font;
    end;
    for Index := 0 to Strings.Count - 1 do
    begin
      Writeln(PrintText, Strings.Strings[Index]);
    end;
  finally
    CloseFile(PrintText);
  end;
end;

procedure EnableDebugPrivilege;
var
  Token: THandle;
  TokenPrivs: TTokenPrivileges;
begin
  if OpenProcessToken(GetCurrentProcess(),TOKEN_ADJUST_PRIVILEGES,Token) then
  begin
    TokenPrivs.PrivilegeCount := 1;
    LookupPrivilegeValue(nil, SE_DEBUG_NAME, TokenPrivs.Privileges[0].Luid);
    TokenPrivs.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
    AdjustTokenPrivileges(Token,False,TokenPrivs,SizeOf(TokenPrivs),nil,DWord(nil^));
    CloseHandle(Token);
  end;
end;

function WinUserName: String;
var
  Buffer: array [0..255] of Char;
  Size: DWord;
begin
  Size := SizeOf(Buffer);
  if not GetUserName(Buffer, Size) then
  begin
    raise EWinUserInformation.Create('Could not collect information on user name');
  end;
  SetString(Result,Buffer,Size - 1);
end;

function WinUserDirectory: String;
begin
  Result := GetEnvironmentVariable('USERPROFILE');
end;

function WinUserAdmin: Boolean;
const
  SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority = (Value: (0,0,0,0,0,5));
  SECURITY_BUILTIN_DOMAIN_RID = $00000020;
  DOMAIN_ALIAS_RID_ADMINS = $00000220;
var
  hAccessToken: THandle;
  ptgGroups: PTokenGroups;
  dwInfoBufferSize: DWORD;
  psidAdministrators: PSID;
  X: Integer;
  bSuccess: BOOL;
begin
  Result := False;
  bSuccess := False;
  ptgGroups := nil;
  psidAdministrators := nil;
  try
    bSuccess := OpenThreadToken(GetCurrentThread,TOKEN_QUERY,True,hAccessToken);
    if not bSuccess then
    begin
      if GetLastError = ERROR_NO_TOKEN then
      begin
        bSuccess := OpenProcessToken(GetCurrentProcess,TOKEN_QUERY,hAccessToken);
      end;
    end;
    if bSuccess then
    begin
      GetMem(ptgGroups,1024);
      bSuccess := GetTokenInformation(hAccessToken,TokenGroups,ptgGroups,1024,dwInfoBufferSize);
      if bSuccess then
      begin
        AllocateAndInitializeSid(SECURITY_NT_AUTHORITY,2,SECURITY_BUILTIN_DOMAIN_RID,DOMAIN_ALIAS_RID_ADMINS,0,0,0,0,0,0,psidAdministrators);
        {$R-}
        for X := 0 to ptgGroups.GroupCount - 1 do
        begin
          if EqualSid(psidAdministrators,ptgGroups.Groups[X].Sid) then
          begin
            Result := True;
            Break;
          end;
        end;
        {$R+}
      end;
    end;
  finally
    if bSuccess then
    begin
      CloseHandle(hAccessToken);
    end;
    if Assigned(ptgGroups) then
    begin
      FreeMem(ptgGroups);
    end;
    if Assigned(psidAdministrators) then
    begin
      FreeSid(psidAdministrators);
    end;
  end;
end;

function WinUserExists(UsrNme: String): Boolean;
begin
  Result := False;
  //...   MUSS NOCH GESCHRIEBEN WERDEN!!!
end;

{ ----------------------------------------------------------------------------
  TFilteredStringList
  ---------------------------------------------------------------------------- }

constructor TFilteredStringList.Create;
begin
  inherited;
  FFilteredStrings := TStringList.Create;
  FFiltered := True;
  FFilterMode := sfmBeginning;
  FFilterOptions := [sfoCaseSensitive,sfoForceTrim,sfoDefaultVisible];
end;

destructor TFilteredStringList.Destroy;
begin
  FFilteredStrings.Free;
  inherited;
end;

function TFilteredStringList.GetFilteredStrings: TStrings;
begin
  if Filtered = True then
  begin
    FilterUpdate;
    Result := FFilteredStrings;
  end else
  begin
    Result := Self;
  end;
end;

procedure TFilteredStringList.FilterUpdate;
var
  Index: Integer;
  StringPos: Integer;
  FilterValue: String;
  StringValue: String;
begin
  FFilteredStrings.Clear;
  for Index := 0 to Count - 1 do
  begin
    FilterValue := Filter;
    StringValue := Strings[Index];
    if not (sfoCaseSensitive in FilterOptions) then
    begin
      FilterValue := LowerCase(FilterValue);
      StringValue := LowerCase(StringValue);
    end;
    if (sfoForceTrim in FilterOptions) then
    begin
      FilterValue := Trim(FilterValue);
      StringValue := Trim(StringValue);
    end;
    StringPos := Pos(FilterValue,StringValue);
    if (((FilterMode = sfmBeginning) and (StringPos = 1)) or
       ((FilterMode = sfmAnyPosition) and (StringPos > 0))) or
       ((Length(FilterValue) = 0) and (sfoDefaultVisible in FilterOptions)) then
    begin
      FFilteredStrings.Add(Strings[Index]);
    end;
  end;
end;

end.