lina-components/Source/uSysCtrls.pas

unit uSysCtrls;

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

interface

uses
  { Standard-Units }
  SysUtils, Classes, Windows, ExtCtrls, TlHelp32, PsAPI,
  { Andere Package-Units }
  uBase, uSysTools;

type
  { Fehlermeldungen }
  EBatteryFlag = class(Exception);

type
  { Hilfsklassen }
  TBatteryFlag = (bfHealthy,bfLow,bfCritical,bfCharge,bfHealthyAccu,bfNone,bfUnknown);
  TBatteryStatus = (bsInternal,bsExternal);
  TProcessRefreshMode = (prNone,prAccess,prTime);

type
  { Hauptklassen }
  TBattery = class(TComponent)
  private
    { Private-Deklarationen }
    FAbout: TComponentAbout;
  protected
    { Protected-Deklarationen }
    function BatteryFlag(Flag: Integer): TBatteryFlag;
  public
    { Public-Deklarationen }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function GetPowerStatus: TBatteryStatus;
    function GetBatteryTime: TDateTime;
    function GetBatteryFullTime: TDateTime;
    function GetBatteryFlag: TBatteryFlag;
    function GetBatteryFlagReport: String;
    function GetBatteryPercent: Byte;
  published
    { Published-Deklarationen }
    property About: TComponentAbout read FAbout;
  end;

  TCursorFix = class(TComponent)
  private
    { Private-Deklarationen }
    FAbout: TComponentAbout;
  public
    { Public-Deklarationen }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published-Deklarationen }
    property About: TComponentAbout read FAbout;
  end;

  TProcessManager = class(TComponent)
  private
    { Private-Deklarationen }
    TimerObject: TTimer;
    FAbout: TComponentAbout;
    FNames: TStrings;
    FTimeOut: DWORD;
    FRefreshMode: TProcessRefreshMode;
    { Methoden }
    function GetNames: TStrings;
    procedure SetRefreshMode(Value: TProcessRefreshMode);
    function GetInterval: Cardinal;
    procedure SetInterval(Value: Cardinal);
    procedure TimerObjectTimer(Sender: TObject);
  public
    { Public-Deklarationen }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Update;
    procedure Kill(ProcID: DWORD);
    function GetID(ProcName: String): DWORD;
    function GetPath(ProcID: DWORD): String;
    function GetThreads(ProcName: String): DWORD;
    function GetParentID(ProcName: String): DWORD;
    function GetPriority(ProcName: String): Integer;
    function GetMemory(ProcID: DWORD): DWORD;
    property Names: TStrings read GetNames;
  published
    { Published-Deklarationen }
    property About: TComponentAbout read FAbout;
    property TimeOut: DWORD read FTimeOut write FTimeOut;
    property RefreshMode: TProcessRefreshMode read FRefreshMode write SetRefreshMode default prNone;
    property Interval: Cardinal read GetInterval write SetInterval default 1000;
  end;

  procedure Register;

const
  { PowerStatus-Meldungen }
  PS_HEALTHY = 'Healthy';
  PS_LOW = 'Low';
  PS_CRITICAL = 'Critical';
  PS_CHARGE = 'Charge';
  PS_HEALTHYACCU = 'HealthyAccu';
  PS_NONE = 'None';
  PS_UNKNOWN = 'Unknown';
  { Meta-Daten }
  BatteryComponent_Name = 'Battery';
  BatteryComponent_Version = 1.0;
  BatteryComponent_Copyright = 'Copyright © 2014';
  BatteryComponent_Author = 'Dennis Göhlert a.o.';

  CursorFixComponent_Name = 'CursorFix';
  CursorFixComponent_Version = 1.0;
  CursorFixComponent_Copyright = 'Copyright © 2014';
  CursorFixComponent_Author = 'Dennis Göhlert a.o.';

  ProcessManagerComponent_Name = 'ProcessManager';
  ProcessManagerComponent_Version = 1.0;
  ProcessManagerComponent_Copyright = 'Copyright © 2014';
  ProcessManagerComponent_Author = 'Dennis Göhlert a.o.';

implementation

procedure Register;
begin
  RegisterComponents(ComponentsPage,[TBattery,TCursorFix,TProcessManager]);
end;

{ ----------------------------------------------------------------------------
  TBattery
  ---------------------------------------------------------------------------- }

function TBattery.BatteryFlag(Flag: Integer): TBatteryFlag;
begin
  case Flag of
    1: Result := bfHealthy;
    2: Result := bfLow;
    4: Result := bfCritical;
    8: Result := bfCharge;
    9: Result := bfHealthyAccu;
    128: Result := bfNone;
    255: Result := bfUnknown;
  else
    begin
      raise EBatteryFlag.Create('Unable to obtain battery flag information');
    end;
  end;
end;

constructor TBattery.Create(AOwner: TComponent);
begin
  inherited;
  FAbout := TComponentAbout.Create(BatteryComponent_Name,BatteryComponent_Version,BatteryComponent_Copyright,BatteryComponent_Author);
end;

destructor TBattery.Destroy;
begin
  FAbout.Free;
  inherited;
end;

function TBattery.GetPowerStatus: TBatteryStatus;
var
  SysPowerStatus: TSystemPowerStatus;
begin
  GetSystemPowerStatus(SysPowerStatus);
  if Boolean(SysPowerStatus.ACLineStatus) then
  begin
    Result := bsExternal;
  end else
  begin
    Result := bsInternal;
  end;
end;

function TBattery.GetBatteryTime: TDateTime;
var
  SysPowerStatus: TSystemPowerStatus;
begin
  GetSystemPowerStatus(SysPowerStatus);
  Result := SecToTime(SysPowerStatus.BatteryLifeTime);
end;

function TBattery.GetBatteryFlag: TBatteryFlag;
var
  SysPowerStatus: TSystemPowerStatus;
begin
  GetSystemPowerStatus(SysPowerStatus);
  Result := BatteryFlag(SysPowerStatus.BatteryFlag);
end;

function TBattery.GetBatteryFlagReport: String;
begin
  case GetBatteryFlag of
    bfHealthy: Result := PS_HEALTHY;
    bfLow: Result := PS_LOW;
    bfCritical: Result := PS_CRITICAL;
    bfCharge: Result := PS_CHARGE;
    bfHealthyAccu: Result := PS_HEALTHYACCU;
    bfNone: Result := PS_NONE;
    bfUnknown: Result := PS_UNKNOWN;
  end;
end;

function TBattery.GetBatteryPercent: Byte;
var
  SysPowerStatus: TSystemPowerStatus;
begin
  GetSystemPowerStatus(SysPowerStatus);
  Result := SysPowerStatus.BatteryLifePercent;
end;

function TBattery.GetBatteryFullTime: TDateTime;
var
  SysPowerStatus: TSystemPowerStatus;
begin
  GetSystemPowerStatus(SysPowerStatus);
  Result := SecToTime(SysPowerStatus.BatteryFullLifeTime);
end;

{ ----------------------------------------------------------------------------
  TCursorFix
  ---------------------------------------------------------------------------- }

constructor TCursorFix.Create(AOwner: TComponent);
{$IFDEF NO_CURSOR}
  var
    CursorHandle: THandle;
{$ENDIF}
begin
  inherited;
  FAbout := TComponentAbout.Create(CursorFixComponent_Name,CursorFixComponent_Version,CursorFixComponent_Copyright,CursorFixComponent_Author);
  {$IFDEF NO_CURSOR}
    CursorHandle := Screen.Cursors[crHandPoint];
    Screen.Cursors[crHandPoint] := LoadCursor(0,IDC_HAND);
    DestroyCursor(CursorHandle);
  {$ELSE}
    {$MESSAGE WARN 'TCursorFix component has been created but not initialized due to the current IDE version'}
    OutputDebugString('TCursorFix component has been created but not initialized due to the current IDE version');
  {$ENDIF}
end;


destructor TCursorFix.Destroy;
{$IFDEF NO_CURSOR}
  var
    CursorHandle: THandle;
{$ENDIF}
begin
  FAbout.Free;
  {$IFDEF NO_CURSOR}
    CursorHandle := Screen.Cursors[crHandPoint];
    Screen.Cursors[crHandPoint] := LoadCursor(0,IDC_HANDPT);
    DestroyCursor(CursorHandle);
  {$ENDIF}
  inherited;
end;

{ ----------------------------------------------------------------------------
  TProcessManager
  ---------------------------------------------------------------------------- }

constructor TProcessManager.Create(AOwner: TComponent);
begin
  inherited;
  FAbout := TComponentAbout.Create(ProcessManagerComponent_Name,ProcessManagerComponent_Version,ProcessManagerComponent_Copyright,ProcessManagerComponent_Author);
  FNames := TStringList.Create;
  TimerObject := TTimer.Create(Self);
  FRefreshMode := prNone;
  TimerObject.OnTimer := TimerObjectTimer;
end;

destructor TProcessManager.Destroy;
begin
  FAbout.Free;
  FNames.Free;
  inherited;
end;

function TProcessManager.GetNames: TStrings;
begin
  if FRefreshMode = prAccess then
  begin
    Update;
  end;
  Result := FNames;
end;

procedure TProcessManager.SetRefreshMode(Value: TProcessRefreshMode);
begin
  FRefreshMode := Value;
  TimerObject.Enabled := (Value = prTime);
end;

procedure TProcessManager.Update;
var
  Snapshot: THandle;
  ProcEntry: TProcessEntry32;
begin
  FNames.Clear;
  Snapshot := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS,0);
  try
    ProcEntry.dwSize := SizeOf(ProcEntry);
    if Process32First(Snapshot,ProcEntry) = True then
    begin
      repeat
        FNames.Add(ProcEntry.szExeFile);
      until (Process32Next(Snapshot,ProcEntry) = False)
    end else
    begin
      RaiseLastOSError;
    end;
  finally
    CloseHandle(Snapshot);
  end;
end;

function TProcessManager.GetInterval: Cardinal;
begin
  Result := TimerObject.Interval;
end;

procedure TProcessManager.SetInterval(Value: Cardinal);
begin
  TimerObject.Interval := Value;
end;

procedure TProcessManager.TimerObjectTimer(Sender: TObject);
begin
  Update;
end;

procedure TProcessManager.Kill(ProcID: DWORD);
var
  CurrentProc: THandle;
  Error: DWORD;
begin
  CurrentProc := OpenProcess(SYNCHRONIZE or PROCESS_TERMINATE,False,ProcID);
  try
    if CurrentProc > 0 then
    begin
      Error := Integer(TerminateProcess(CurrentProc,1));
      if Error <> 0 then
      begin
        Error := WaitForSingleObject(CurrentProc,FTimeOut);
        if Error = WAIT_FAILED then
        begin
          RaiseLastOSError;
        end;
      end else
      begin
        RaiseLastOSError;
      end;
    end else
    begin
      RaiseLastOSError;
    end;
  finally
    CloseHandle(CurrentProc);
  end;
end;

function TProcessManager.GetID(ProcName: String): DWORD;
var
  Snapshot: THandle;
  ProcEntry: TProcessEntry32;
begin
  Result := 0;
  Snapshot := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS,0);
  try
    ProcEntry.dwSize := SizeOf(ProcEntry);
    if Process32First(Snapshot,ProcEntry) then
    begin
      repeat
        if Pos(AnsiLowerCase(ProcEntry.szExeFile),AnsiLowerCase(ExtractFilename(ProcName))) > 0 then
        begin
          Result := ProcEntry.th32ProcessID;
          Break;
        end;
      until (Process32Next(Snapshot,ProcEntry) = False)
    end else
    begin
      RaiseLastOSError;
    end;
  finally
    CloseHandle(Snapshot);
  end;
end;

function TProcessManager.GetPath(ProcID: DWORD): String;
var
  Snapshot: THandle;
  ModEntry: TModuleEntry32;
begin
  Result := '';
  Snapshot := CreateToolHelp32Snapshot(TH32CS_SNAPMODULE,ProcID);
  try
    ModEntry.dwSize := SizeOf(ModEntry);
    if Module32First(Snapshot,ModEntry) then
    begin
      Result := ModEntry.szExePath;
    end else
    begin
      RaiseLastOSError;
    end;
  finally
    CloseHandle(Snapshot);
  end;
end;

function TProcessManager.GetThreads(ProcName: String): DWORD;
var
  Snapshot: THandle;
  ProcEntry: TProcessEntry32;
begin
  Result := 0;
  Snapshot := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS,0);
  try
    ProcEntry.dwSize := SizeOf(ProcEntry);
    if Process32First(Snapshot,ProcEntry) then
    begin
      repeat
        if Pos(AnsiLowerCase(ProcEntry.szExeFile),AnsiLowerCase(ExtractFilename(ProcName))) > 0 then
        begin
          Result := ProcEntry.cntThreads;
          Break;
        end;
      until (Process32Next(Snapshot,ProcEntry) = False)
    end else
    begin
      RaiseLastOSError;
    end;
  finally
    CloseHandle(Snapshot);
  end;
end;

function TProcessManager.GetParentID(ProcName: String): DWORD;
var
  Snapshot: THandle;
  ProcEntry: TProcessEntry32;
begin
  Result := 0;
  Snapshot := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS,0);
  try
    ProcEntry.dwSize := SizeOf(ProcEntry);
    if Process32First(Snapshot,ProcEntry) then
    begin
      repeat
        if Pos(AnsiLowerCase(ProcEntry.szExeFile),AnsiLowerCase(ExtractFilename(ProcName))) > 0 then
        begin
          Result := ProcEntry.th32ParentProcessID;
          Break;
        end;
      until (Process32Next(Snapshot,ProcEntry) = False)
    end else
    begin
      RaiseLastOSError;
    end;
  finally
    CloseHandle(Snapshot);
  end;
end;

function TProcessManager.GetPriority(ProcName: String): Integer;
var
  Snapshot: THandle;
  ProcEntry: TProcessEntry32;
begin
  Result := -1;
  Snapshot := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS,0);
  try
    ProcEntry.dwSize := SizeOf(ProcEntry);
    if Process32First(Snapshot,ProcEntry) then
    begin
      repeat
        if Pos(AnsiLowerCase(ProcEntry.szExeFile),AnsiLowerCase(ExtractFilename(ProcName))) > 0 then
        begin
          Result := ProcEntry.pcPriClassBase;
          Break;
        end;
      until (Process32Next(Snapshot,ProcEntry) = False)
    end else
    begin
      RaiseLastOSError;
    end;
  finally
    CloseHandle(Snapshot);
  end;
end;

function TProcessManager.GetMemory(ProcID: DWORD): DWORD;
var
  ProcMem: TProcessMemoryCounters;
begin
  Result := 0;
  ProcMem.cb := SizeOf(ProcMem);
  if GetProcessMemoryInfo(OpenProcess(PROCESS_QUERY_INFORMATION,False,ProcID),@ProcMem,SizeOf(ProcMem)) = True then
  begin
    Result := ProcMem.WorkingSetSize;
  end else
  begin
    RaiseLastOSError;
  end;
end;

end.