Version 1.0 DEV 1.09

Signed-off-by: Dennis07 <den.goehlert@t-online.de>

Information/Statistics.txt

@@ -1,4 +1,4 @@
 These statistics cover the official repository of Lina Components.
 
-Total lines of code (LoC): 4700+
+Total lines of code (LoC): 4800+
 Total visual components (VC): 13

Source/uSysCtrls.pas

@@ -10,7 +10,7 @@ interface
 
 uses
   { Standard-Units }
-  SysUtils, Classes, Windows, TlHelp32, PsAPI,
+  SysUtils, Classes, Windows, ExtCtrls, TlHelp32, PsAPI,
   { Andere Package-Units }
   uBase, uSysTools;
 
@@ -22,6 +22,7 @@ type
   { Hilfsklassen }
   TBatteryFlag = (bfHealthy,bfLow,bfCritical,bfCharge,bfHealthyAccu,bfNone,bfUnknown);
   TBatteryStatus = (bsInternal,bsExternal);
+  TProcessRefreshMode = (prNone,prAccess,prTime);
 
 type
   { Hauptklassen }
@@ -63,9 +64,17 @@ type
   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;
@@ -81,8 +90,10 @@ type
   published
     { Published-Deklarationen }
     property About: TComponentAbout read FAbout;
-    property Names: TStrings read FNames;
+    property Names: TStrings read GetNames;
     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;
@@ -258,6 +269,9 @@ 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;
@@ -267,6 +281,21 @@ begin
   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;
@@ -276,7 +305,7 @@ begin
   Snapshot := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS,0);
   try
     ProcEntry.dwSize := SizeOf(ProcEntry);
-    if Process32First(Snapshot,ProcEntry) then
+    if Process32First(Snapshot,ProcEntry) = True then
     begin
       repeat
         FNames.Add(ProcEntry.szExeFile);
@@ -290,6 +319,21 @@ begin
   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;
@@ -451,20 +495,16 @@ end;
 
 function TProcessManager.GetMemory(ProcID: DWORD): DWORD;
 var
-  ProcMem: PPROCESS_MEMORY_COUNTERS;
-  CB: Integer;
+  ProcMem: TProcessMemoryCounters;
 begin
   Result := 0;
-  CB := SizeOf(_PROCESS_MEMORY_COUNTERS);
-  GetMem(ProcMem,CB);
-  ProcMem^.cb := CB;
-  try
-    if GetProcessMemoryInfo(OpenProcess(PROCESS_ALL_ACCESS,False,ProcID),ProcMem,CB) = True then
-    begin
-      Result := ProcMem^.WorkingSetSize;
-    end;
-  finally
-    FreeMem(ProcMem);
+  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;
 

Source/uSysTools.pas

@@ -93,9 +93,11 @@ type
   function CharUpperCase(Character: Char): Char;
   function FontSizeToHeight(Size: Integer; PpI: Integer): Integer;
   function FontHeightToSize(Height: Integer; PpI: Integer): Integer;
+  procedure EnableDebugPrivilege;
 
 const
   Spaces = [#9,#10,#13,#32,#160];
+  SE_DEBUG_NAME = 'SeDebugPrivilege';
 
 implementation
 
@@ -304,6 +306,21 @@ begin
   Result := - Height * 72 div PpI;
 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;