FMX, TGrid, OnCellClick - events

On my fmx-form I have TGrid with column of type TCheckColumn. To capture click events on cells of grid I connect the OnCellClick handler to it.
My Question is: how to reliably trigger the OnCellClick event when clicking the left mouse button (LMB) for an arbitrary line, if:
LMB clicks occur on the same cell in the TCheckColumn;
LMB clicks are not accompanied by mouse cursor displacement.
For a better explanation of the essence of the issue, I will give a picture (see below). LMB is pressed on it in the same cell without cursor offsets. Events arising in this situation are logged in the CodeSite window (on the right). As you can see from the picture: the cell in the TCheckColumn column changes its state (the checkmark appears or disappears), but the OnCellClick event occurs only 1 time.
The picture itself
TGrid with OnCellClick event handler:
unit uMain;
interface
uses
System.SysUtils,
System.Types,
System.UITypes,
System.Classes,
System.Variants,
System.Rtti,
//
FMX.Types,
FMX.Controls,
FMX.Forms,
FMX.Graphics,
FMX.Dialogs,
FMX.Grid.Style,
FMX.Grid,
FMX.Controls.Presentation,
FMX.ScrollBox,
FMX.StdCtrls,
FMX.ImgList;
//
type
//for grid row
TRow = record
ID:integer;
Checked:boolean;
end;
//Test form
TForm1 = class(TForm)
grd: TGrid;
CheckColumn2: TCheckColumn;
Label2: TLabel;
IntegerColumn1: TIntegerColumn;
procedure FormCreate(Sender: TObject);
procedure grdGetValue(Sender: TObject; const ACol, ARow: Integer; var Value: TValue);
procedure grdSetValue(Sender: TObject; const ACol, ARow: Integer; const Value: TValue);
procedure grdCellClick(const Column: TColumn; const Row: Integer);
private
FRowsA: array of TRow;
FSelectedRow: integer;
//
procedure PopulateGrid;
//
end;
//for cols of grid
TMyCols = (mcID, mcChecked);
var
Form1: TForm1;
implementation
{$R *.fmx}
//FormCreate
procedure TForm1.FormCreate(Sender: TObject);
begin
PopulateGrid;
end;
{$REGION 'TGrid'}
//PopulateGrid
procedure TForm1.PopulateGrid;
const
rows = 10;//rows count
begin
Grd.RowCount := rows ;
SetLength(FRowsA, rows);
for var r := 0 to rows-1 do
begin
//
FRowsA[r].ID := r; //id
FRowsA[r].Checked := false ; //check
end;
end;
//grdCellClick
procedure TForm1.grdCellClick(const Column: TColumn; const Row: Integer);
var
selRow, cnt: integer;
begin
var ci := Column.Index ;
FSelectedRow := Row;
cnt := grd.RowCount ;
//checked col
if ci = Ord(TMyCols.mcChecked) then
begin
//
grd.RowCount := 0;
grd.RowCount := cnt;
grd.SelectRow(FSelectedRow);
//
FRowsA[Row].Checked := not FRowsA[Row].Checked;
//
Log.d( Format('CellClick raised: row=%d; col=%d', [Row, ci]) );
end;
end;
//grdSetValue
procedure TForm1.grdSetValue(Sender: TObject; const ACol, ARow: Integer; const Value: TValue);
var
oldVal, newVal: boolean;
begin
var g := Sender as TGrid;
if not Assigned(g) then Exit;
if (ARow < 0) or (ARow >= g.RowCount) then Exit;
//
//col num
case ACol of
//id col
Ord(TMyCols.mcID):
begin
FRowsA[ARow].Checked := Value.AsBoolean;//id
end;
//checked col
Ord(TMyCols.mcChecked):
begin
oldVal := FRowsA[ARow].Checked;
Value.TryAsType<boolean>(newVal);
FRowsA[ARow].Checked := newVal;//checked
Log.d( Format('OnSetValue raised: row=%d; col=%d; oldValue=%s; newValue=%s', [ARow, ACol, oldVal.ToString(), newVal.ToString()]) );
end;
//
end;
//
end;
//grdGetValue
procedure TForm1.grdGetValue(Sender: TObject; const ACol, ARow: Integer; var Value: TValue);
var
val: boolean;
begin
var g := Sender as TGrid;
if not Assigned(g) then Exit;
if (ARow < 0) or (ARow >= g.RowCount) then Exit;
case ACol of
//id
Ord(TMyCols.mcID) :
begin
Value := FRowsA[ARow].ID;
end;
//checked
Ord(TMyCols.mcChecked):
begin
Value := FRowsA[ARow].Checked;
end;
end;
Log.d( Format('OnGetValue raised: row=%d; col=%d', [ARow, ACol]) );
//
end;
{$ENDREGION}
//
end.

Related

Get CPU usage with Delphi [duplicate]

I am trying to get the % of total CPU usage to a label1.Caption
I've searched and found these:
didn't work - http://www.vbforums.com/showthread.php?345723-DELPHI-Get-CPU-Usage
not what I need - http://delphi.cjcsoft.net/viewthread.php?tid=42837
also found bunch of solutions regarding calculating the Usage per process but that is not what i am looking for , i just want the total CPU usage
like this widget :
this is what i am working on :
I believe there is a simple way like when we get RAM usage.
GlobalMemoryStatus(RamStats);
Label1.Caption := Format('RAM: %d %%', [RamStats.dwMemoryLoad]);
I have found an article, determine-cpu-usage-of-current-process-c-and-c, about how to get the CPU usage of the current process.
Now we need to do a bit more to compute the Total CPU usage percentage by adding up CPU usage percentage for each running processes:
function GetTotalCpuUsagePct(): Double;
var
ProcessID: TProcessID;
RunningProcessIDs : TArray<TProcessID>;
begin
Result := 0.0;
RunningProcessIDs := GetRunningProcessIDs;
DeleteNonExistingProcessIDsFromCache(RunningProcessIDs);
for ProcessID in RunningProcessIDs do
Result := Result + GetProcessCpuUsagePct( ProcessID );
end;
After getting running process id's, we start out calling
DeleteNonExistingProcessIDsFromCache to clean up the cache, that holds previous Cpu usage times needed in GetProcessCpuUsagePct: Every process that has been stopped since last query is removed from this cache.
The GetProcessCpuUsagePct is the core, which is a translation of determine-cpu-usage-of-current-process-c-and-c. This function needs to retrieve the previous reading from the Cpu Usage Cache LatestProcessCpuUsageCache (global in the unit) using the ProcessID.
Note, it is not recommended to call GetToalCpuUsageCpu less than every 200 ms, as it may give wrong results.
function GetProcessCpuUsagePct(ProcessID: TProcessID): Double;
function SubtractFileTime(FileTime1: TFileTIme; FileTime2: TFileTIme): TFileTIme;
begin
Result := TFileTIme(Int64(FileTime1) - Int64(FileTime2));
end;
var
ProcessCpuUsage: TProcessCpuUsage;
ProcessHandle: THandle;
SystemTimes: TSystemTimesRec;
SystemDiffTimes: TSystemTimesRec;
ProcessDiffTimes: TProcessTimesRec;
ProcessTimes: TProcessTimesRec;
SystemTimesIdleTime: TFileTime;
ProcessTimesCreationTime: TFileTime;
ProcessTimesExitTime: TFileTime;
begin
Result := 0.0;
LatestProcessCpuUsageCache.TryGetValue(ProcessID, ProcessCpuUsage);
if ProcessCpuUsage = nil then
begin
ProcessCpuUsage := TProcessCpuUsage.Create;
LatestProcessCpuUsageCache.Add(ProcessID, ProcessCpuUsage);
end;
// method from:
// http://www.philosophicalgeek.com/2009/01/03/determine-cpu-usage-of-current-process-c-and-c/
ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, ProcessID);
if ProcessHandle <> 0 then
begin
try
if GetSystemTimes(SystemTimesIdleTime, SystemTimes.KernelTime, SystemTimes.UserTime) then
begin
SystemDiffTimes.KernelTime := SubtractFileTime(SystemTimes.KernelTime, ProcessCpuUsage.LastSystemTimes.KernelTime);
SystemDiffTimes.UserTime := SubtractFileTime(SystemTimes.UserTime, ProcessCpuUsage.LastSystemTimes.UserTime);
ProcessCpuUsage.LastSystemTimes := SystemTimes;
if GetProcessTimes(ProcessHandle, ProcessTimesCreationTime, ProcessTimesExitTime, ProcessTimes.KernelTime, ProcessTimes.UserTime) then
begin
ProcessDiffTimes.KernelTime := SubtractFileTime(ProcessTimes.KernelTime, ProcessCpuUsage.LastProcessTimes.KernelTime);
ProcessDiffTimes.UserTime := SubtractFileTime(ProcessTimes.UserTime, ProcessCpuUsage.LastProcessTimes.UserTime);
ProcessCpuUsage.LastProcessTimes := ProcessTimes;
if (Int64(SystemDiffTimes.KernelTime) + Int64(SystemDiffTimes.UserTime)) > 0 then
Result := (Int64(ProcessDiffTimes.KernelTime) + Int64(ProcessDiffTimes.UserTime)) / (Int64(SystemDiffTimes.KernelTime) + Int64(SystemDiffTimes.UserTime)) * 100;
end;
end;
finally
CloseHandle(ProcessHandle);
end;
end;
end;
Here is a screen shot of the result on a Windows 7.
Full Listing of unit:
unit uTotalCpuUsagePct;
interface
function GetTotalCpuUsagePct : Double;
implementation
uses
SysUtils, DateUtils, Windows, PsAPI, TlHelp32, ShellAPI, Generics.Collections;
type
TProcessID = DWORD;
TSystemTimesRec = record
KernelTime: TFileTIme;
UserTime: TFileTIme;
end;
TProcessTimesRec = record
KernelTime: TFileTIme;
UserTime: TFileTIme;
end;
TProcessCpuUsage = class
LastSystemTimes: TSystemTimesRec;
LastProcessTimes: TProcessTimesRec;
ProcessCPUusagePercentage: Double;
end;
TProcessCpuUsageList = TObjectDictionary<TProcessID, TProcessCpuUsage>;
var
LatestProcessCpuUsageCache : TProcessCpuUsageList;
LastQueryTime : TDateTime;
(* -------------------------------------------------------------------------- *)
function GetRunningProcessIDs: TArray<TProcessID>;
var
SnapProcHandle: THandle;
ProcEntry: TProcessEntry32;
NextProc: Boolean;
begin
SnapProcHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if SnapProcHandle <> INVALID_HANDLE_VALUE then
begin
try
ProcEntry.dwSize := SizeOf(ProcEntry);
NextProc := Process32First(SnapProcHandle, ProcEntry);
while NextProc do
begin
SetLength(Result, Length(Result) + 1);
Result[Length(Result) - 1] := ProcEntry.th32ProcessID;
NextProc := Process32Next(SnapProcHandle, ProcEntry);
end;
finally
CloseHandle(SnapProcHandle);
end;
TArray.Sort<TProcessID>(Result);
end;
end;
(* -------------------------------------------------------------------------- *)
function GetProcessCpuUsagePct(ProcessID: TProcessID): Double;
function SubtractFileTime(FileTime1: TFileTIme; FileTime2: TFileTIme): TFileTIme;
begin
Result := TFileTIme(Int64(FileTime1) - Int64(FileTime2));
end;
var
ProcessCpuUsage: TProcessCpuUsage;
ProcessHandle: THandle;
SystemTimes: TSystemTimesRec;
SystemDiffTimes: TSystemTimesRec;
ProcessDiffTimes: TProcessTimesRec;
ProcessTimes: TProcessTimesRec;
SystemTimesIdleTime: TFileTime;
ProcessTimesCreationTime: TFileTime;
ProcessTimesExitTime: TFileTime;
begin
Result := 0.0;
LatestProcessCpuUsageCache.TryGetValue(ProcessID, ProcessCpuUsage);
if ProcessCpuUsage = nil then
begin
ProcessCpuUsage := TProcessCpuUsage.Create;
LatestProcessCpuUsageCache.Add(ProcessID, ProcessCpuUsage);
end;
// method from:
// http://www.philosophicalgeek.com/2009/01/03/determine-cpu-usage-of-current-process-c-and-c/
ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, ProcessID);
if ProcessHandle <> 0 then
begin
try
if GetSystemTimes(SystemTimesIdleTime, SystemTimes.KernelTime, SystemTimes.UserTime) then
begin
SystemDiffTimes.KernelTime := SubtractFileTime(SystemTimes.KernelTime, ProcessCpuUsage.LastSystemTimes.KernelTime);
SystemDiffTimes.UserTime := SubtractFileTime(SystemTimes.UserTime, ProcessCpuUsage.LastSystemTimes.UserTime);
ProcessCpuUsage.LastSystemTimes := SystemTimes;
if GetProcessTimes(ProcessHandle, ProcessTimesCreationTime, ProcessTimesExitTime, ProcessTimes.KernelTime, ProcessTimes.UserTime) then
begin
ProcessDiffTimes.KernelTime := SubtractFileTime(ProcessTimes.KernelTime, ProcessCpuUsage.LastProcessTimes.KernelTime);
ProcessDiffTimes.UserTime := SubtractFileTime(ProcessTimes.UserTime, ProcessCpuUsage.LastProcessTimes.UserTime);
ProcessCpuUsage.LastProcessTimes := ProcessTimes;
if (Int64(SystemDiffTimes.KernelTime) + Int64(SystemDiffTimes.UserTime)) > 0 then
Result := (Int64(ProcessDiffTimes.KernelTime) + Int64(ProcessDiffTimes.UserTime)) / (Int64(SystemDiffTimes.KernelTime) + Int64(SystemDiffTimes.UserTime)) * 100;
end;
end;
finally
CloseHandle(ProcessHandle);
end;
end;
end;
(* -------------------------------------------------------------------------- *)
procedure DeleteNonExistingProcessIDsFromCache(const RunningProcessIDs : TArray<TProcessID>);
var
FoundKeyIdx: Integer;
Keys: TArray<TProcessID>;
n: Integer;
begin
Keys := LatestProcessCpuUsageCache.Keys.ToArray;
for n := Low(Keys) to High(Keys) do
begin
if not TArray.BinarySearch<TProcessID>(RunningProcessIDs, Keys[n], FoundKeyIdx) then
LatestProcessCpuUsageCache.Remove(Keys[n]);
end;
end;
(* -------------------------------------------------------------------------- *)
function GetTotalCpuUsagePct(): Double;
var
ProcessID: TProcessID;
RunningProcessIDs : TArray<TProcessID>;
begin
Result := 0.0;
RunningProcessIDs := GetRunningProcessIDs;
DeleteNonExistingProcessIDsFromCache(RunningProcessIDs);
for ProcessID in RunningProcessIDs do
Result := Result + GetProcessCpuUsagePct( ProcessID );
end;
(* -------------------------------------------------------------------------- *)
initialization
LatestProcessCpuUsageCache := TProcessCpuUsageList.Create( [ doOwnsValues ] );
// init:
GetTotalCpuUsagePct;
finalization
LatestProcessCpuUsageCache.Free;
end.
Test Code:
unit Unit1;
interface
uses
Vcl.Forms, System.SysUtils, Vcl.Controls, Vcl.StdCtrls, System.Classes,
Vcl.ExtCtrls,
uTotalCpuUsagePct;
type
TForm1 = class(TForm)
Timer1: TTimer;
Label1: TLabel;
procedure Timer1Timer(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
// start cpu load thread
TThread.CreateAnonymousThread(
procedure
begin
while True do
begin
end;
end).Start;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
TotalCPUusagePercentage: Double;
begin
TotalCPUusagePercentage := GetTotalCpuUsagePct();
Label1.Caption := 'Total cpu: ' + IntToStr(Round(TotalCPUusagePercentage)) + '%';
end;
end.
You can achieve your goal using the Performance Counters Functions from Microsoft.
Limited User Access Support
Only the administrator of the computer or users in the Performance Logs User Group can log and view counter data. Users in the Administrator group can log and view counter data only if the tool they use to log and view counter data is started from a Command Prompt window that is opened with Run as administrator.... Users in the Performance Monitoring Users group can view counter data.
I have found this answer - see CPU currently used - from the Lanzelot user here on SO and I have done some porting to Delphi.
Raw porting:
program Project1;
{$APPTYPE CONSOLE}
uses
SysUtils,
pdh in 'pdh.pas';
var
cpuQuery: HQUERY;
cpuTotal: HCOUNTER;
i: Integer;
procedure init;
begin
PdhOpenQuery(nil, 0, cpuQuery);
PdhAddCounter(cpuQuery, '\Processor(_Total)\% Processor Time', 0, cpuTotal);
PdhCollectQueryData(cpuQuery);
end;
function getCurrentValue: Double;
var
counterVal: TPdhFmtCounterValue;
begin
PdhCollectQueryData(cpuQuery);
PdhGetFormattedCounterValue(cpuTotal, PDH_FMT_DOUBLE, nil, counterVal);
Result := counterVal.doubleValue;
end;
The example requires the pdh unit which I have grabbed from here.
The WinPerf unit is needed by the pdh and I have downloaded it from here.
Basic test in a console application:
begin
init;
for i := 1 to 60 do begin
//let's monitor the CPU usage for one minute
WriteLn(getCurrentValue);
Sleep(1000);
end;
PdhCloseQuery(cpuQuery);
end.
A more useful example based on the TThread class.
This allows to obtain different counters based on the parameter passed to the ACounterPath argument in the constructor.
counterThread.pas
unit counterThread;
interface
uses
Classes, Windows, SyncObjs, pdh;
type
TCounterNotifyEvent = procedure(AValue: Double) of object;
TCounterThread = class(TThread)
private
FInterval: Integer;
FWaitEvent: TEvent;
FHQuery: HQUERY;
FHCounter: HCOUNTER;
procedure checkSuccess(AResult: Integer);
protected
procedure Execute; override;
procedure TerminatedSet; override;
public
OnCounter: TCounterNotifyEvent;
constructor Create(const ACounterPath: PChar; AInterval: Cardinal; ACreateSuspended: Boolean);
destructor Destroy; override;
end;
implementation
uses
SysUtils;
procedure TCounterThread.checkSuccess(AResult: Integer);
begin
if ERROR_SUCCESS <> AResult then
RaiseLastOSError;
end;
constructor TCounterThread.Create(const ACounterPath: PChar; AInterval: Cardinal; ACreateSuspended: Boolean);
begin
inherited Create(ACreateSuspended);
FInterval := AInterval;
FWaitEvent := TEvent.Create(nil, False, False, '');
FHQuery := INVALID_HANDLE_VALUE;
checkSuccess(PdhOpenQuery(nil, 0, FHQuery));
checkSuccess(PdhAddCounter(FHQuery, ACounterPath, 0, FHCounter));
//checkSuccess(PdhAddEnglishCounter(FHQuery, ACounterPath, 0, FHCounter));
checkSuccess(PdhCollectQueryData(FHQuery));
end;
destructor TCounterThread.Destroy;
begin
FWaitEvent.Free;
if (FHQuery <> 0) and (FHQuery <> INVALID_HANDLE_VALUE) then
PdhCloseQuery(FHQuery);
inherited;
end;
procedure TCounterThread.TerminatedSet;
begin
inherited;
FWaitEvent.SetEvent;
end;
procedure TCounterThread.Execute;
var
counterVal: TPdhFmtCounterValue;
begin
inherited;
while not Terminated do begin
checkSuccess(PdhCollectQueryData(FHQuery));
FillChar(counterVal, SizeOf(TPdhFmtCounterValue), 0);
checkSuccess(PdhGetFormattedCounterValue(FHCounter, PDH_FMT_DOUBLE, nil, counterVal));
if Assigned(OnCounter) then
OnCounter(counterVal.doubleValue);
FWaitEvent.WaitFor(FInterval);
end;
end;
end.
Unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls,
counterThread;
type
TForm1 = class(TForm)
Edit1: TEdit;
Button1: TButton;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
FCpuCounter: TCounterThread;
procedure CpuCounterCounter(AValue: Double);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
FCpuCounter := TCounterThread.Create('\Processor(_Total)\% Processor Time', 1000, False);
//'\Processore(_Total)\% Tempo Processore'
with FCpuCounter do begin
FreeOnTerminate := True;
OnCounter := CpuCounterCounter;
end;
Button1.Enabled := False;
end;
procedure TForm1.CpuCounterCounter(AValue: Double);
begin
Edit1.Text := FloatToStr(AValue);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
if Assigned(FCpuCounter) then
FCpuCounter.Terminate;
end;
end.
Unit1.dfm
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 123
ClientWidth = 239
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 8
Top = 24
Width = 97
Height = 13
Caption = 'Total CPU usage %:'
end
object Edit1: TEdit
Left = 111
Top = 21
Width = 99
Height = 21
TabOrder = 0
end
object Button1: TButton
Left = 111
Top = 80
Width = 99
Height = 25
Caption = 'Start monitoring'
TabOrder = 1
OnClick = Button1Click
end
end
OFF TOPIC
I'm currently at home and I've not a Delphi XE here so I coded it with Turbo Delphi, I have no pdh unit installed on my machine and I can't know at the moment if Delphi XE has the units.
NOTICE
I have used the PdhAddCounter function instead of the PdhAddEnglishCounter because the function reference is missing in the unit. Unfortunately, after I added the reference, the function was still missing in the Pdh.dll on my old Windows XP.
The szFullCounterPath of the PdhAddCounter is localized so I have to use the italian localized path on my Windows \Processore(_Total)\% Tempo Processore.
If you use the PdhAddEnglishCounter function or your locale is english, you have to use the path \Processor(_Total)\% Processor Time.
If your system locale is other than english or italian, you have to find the path by yourself using the PdhBrowseCounters function.
The very basic function usage which follows needs the PdhMsg unit.
See also MSDN Browsing Performance Counters for further reference.
function CounterPathCallBack(dwArg: DWORD_PTR): Longint; stdcall;
begin
Form1.Memo1.Lines.Add(PChar(dwArg));
Result := ERROR_SUCCESS;
end;
procedure TForm1.Button2Click(Sender: TObject);
const
PDH_MAX_COUNTER_PATH = 255;//maybe ?
BROWSE_DIALOG_CAPTION: PChar = 'Select a counter to monitor.';
var
browseDlgData: TPdhBrowseDlgConfig;
counterPathBuffer: array [0..PDH_MAX_COUNTER_PATH-1] of Char;
status: LongInt;
begin
FillChar(browseDlgData, SizeOf(TPdhBrowseDlgConfig), 0);
with browseDlgData do begin
{bIncludeInstanceIndex = FALSE;
bSingleCounterPerAdd = TRUE;
bSingleCounterPerDialog = TRUE;
bLocalCountersOnly = FALSE;
bWildCardInstances = TRUE;
bHideDetailBox = TRUE;
bInitializePath = FALSE;
bDisableMachineSelection = FALSE;
bIncludeCostlyObjects = FALSE;
bShowObjectBrowser = FALSE;}
hWndOwner := Self.Handle;
szReturnPathBuffer := #counterPathBuffer[0];
cchReturnPathLength := PDH_MAX_COUNTER_PATH;
pCallBack := CounterPathCallBack;
dwCallBackArg := DWORD_PTR(#counterPathBuffer[0]);
CallBackStatus := ERROR_SUCCESS;
dwDefaultDetailLevel := PERF_DETAIL_WIZARD;
szDialogBoxCaption := BROWSE_DIALOG_CAPTION;
end;
status := PdhBrowseCounters(browseDlgData);
case status of
PDH_DIALOG_CANCELLED, ERROR_SUCCESS:
;
else
RaiseLastOSError;
end;
end;
http://www.magsys.co.uk/delphi/
Get the MagWMI component. It's free.
This component will allow you to access the WMI pretty easily which already has the info you want. I just tested an old program I had using this on Win 10 and it correctly found all 8 of my cores and the processor usage.
And then do something like this:
var
compname:string;
WmiResults: T2DimStrArray ;
instances, i : Integer
Begin
compname:=getcompname; // a function in the MagWMI to get the computer name.
MagWmiGetInfoEx (compname, '', '',
'', 'SELECT percentidletime FROM Win32_PerfFormattedData_PerfOS_Processor', WmiResults, instances, errstr) ;
for i := 1 to instances do
begin
// wmiresults[i,2] will hold the percentage for each processor found.
end;
I solve this way:
function TCPU.get_param_value(param_name: String): String;
var
command,
file_out: String;
data_file: TStringList;
begin
data_file := TStringList.Create;
try
try
file_out := TPath.GetTempPath + FormatDateTime('yyyymmddhhnnss', Now) + '_CPUInfo.txt';
comando := '"wmic cpu get '+param_name+' /value | find "'+param_name+'" > ' +
file_out + '&&exit"';
// "runas" for admin privileges, or "open" to any user
ShellExecute(0, 'open', 'cmd.exe', PChar('/k ' + command), nil, SW_HIDE);
// Wait 4 sec to cmd release the process...
Sleep(4000);
data_file.LoadFromFile(file_out);
Result := data_file.Values[param_name];
except
Result := '';
end;
finally
TFile.Delete(file_out);
data_file.Free;
end;
In this way, you can get any param values from wmic
I found t h i s
does the job
uses adCpuUsage;
procedure TForm1.Button1Click(Sender: TObject);
var
i:integer;
u:string;
begin
collectcpudata;
for i:=0 to GetCPUCount-1 do
u:=FloatToStr(Round(getcpuusage(i)*100)); //Round to approximate 1.0003 to 1
label1.Caption:=u
end;
end.
worked for me

How to display list text with other controls on same line?

As an exercise for myself, I'm trying to recreate the To-Do app from the (fascinating) todomvc.com web site. The UI looks like this:
A user writes a To-Do item in an Edit box control (above the crossed out "buy milk") and presses Enter. To-Do items appear below.
As you can see, each line includes a stylized radio control, the text, and a button with an image (red x). The button appears when a user hovers the cursor inside the line.
I don't care about the button, having an image, or appearing only upon OnEnter. I can't figure out how to make a similarly styled (ListView? ComboBox?) control with a radio control and button.
I'm using Delphi VCL, but could switch to FMX.
There really isn't any shortcut here: you simply need to write quite a lot of code. The Windows OS doesn't provide anything like this. I would implement from scratch using an empty window with custom GDI painting and mouse and keyboard input processing. It's not difficult at all, but it does require quite a lot of code.
That was a lot of words and no code.
As a remedy, here is a very quick demonstration control based on Direct2D (because I realised I really do need anti aliasing):
unit ItemListBox;
interface
uses
Windows, SysUtils, Types, UITypes, Classes, Controls, Graphics, Generics.Defaults,
Generics.Collections, Forms, Messages, Direct2D, D2D1;
type
TItem = class
strict private
FCaption: TCaption;
FChecked: Boolean;
FTag: NativeInt;
FOnChanged: TNotifyEvent;
procedure Changed;
procedure SetCaption(const Value: TCaption);
procedure SetChecked(const Value: Boolean);
public
property Caption: TCaption read FCaption write SetCaption;
property Checked: Boolean read FChecked write SetChecked;
property Tag: NativeInt read FTag write FTag;
property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;
end;
TPart = (ilbpText, ilbpCheckBox, ilbpClearButton);
TItemListBox = class(TCustomControl)
strict private
FItems: TObjectList<TItem>;
FItemHeight: Integer;
FCanvas: TDirect2DCanvas;
FIndex: Integer;
FPart: TPart;
FMouseDownIndex: Integer;
FMouseDownPart: TPart;
FFocusIndex: Integer;
function GetItem(Index: Integer): TItem;
function GetItemCount: Integer;
procedure ItemChanged(Sender: TObject);
procedure DrawItem(Index: Integer; Item: TItem);
procedure DrawCheckBox(Index: Integer; Item: TItem; Hot: Boolean = False);
procedure DrawClearButton(Index: Integer; Visible: Boolean; Hot: Boolean = False);
function ItemRect(Index: Integer): TRect;
function TextRect(Index: Integer): TRect;
function CheckBoxRect(Index: Integer): TRect;
function ClearButtonRect(Index: Integer): TRect;
procedure CreateDeviceResources;
procedure HitTest(const P: TPoint; out Index: Integer; out Part: TPart);
procedure StateChange(ANewIndex: Integer; ANewPart: TPart);
function CanvasWidth: Integer;
function CanvasHeight: Integer;
protected
procedure Paint; override;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure CreateWnd; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer;
Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
Y: Integer); override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Canvas: TDirect2DCanvas read FCanvas;
function AddItem(const ACaption: string; AChecked: Boolean;
ATag: NativeInt = 0): Integer;
procedure RemoveItem(AIndex: Integer);
property Items[Index: Integer]: TItem read GetItem;
property ItemCount: Integer read GetItemCount;
published
property Align;
property AlignWithMargins;
property Anchors;
property Cursor;
property Font;
property Hint;
property PopupMenu;
property TabOrder;
property TabStop default True;
end;
procedure Register;
implementation
uses
Math;
procedure Register;
begin
RegisterComponents('Rejbrand 2020', [TItemListBox]);
end;
function Scale(X: Integer): Integer;
begin
Result := MulDiv(X, Screen.PixelsPerInch, 96);
end;
{ TItem }
procedure TItem.Changed;
begin
if Assigned(FOnChanged) then
FOnChanged(Self);
end;
procedure TItem.SetCaption(const Value: TCaption);
begin
if FCaption <> Value then
begin
FCaption := Value;
Changed;
end;
end;
procedure TItem.SetChecked(const Value: Boolean);
begin
if FChecked <> Value then
begin
FChecked := Value;
Changed;
end;
end;
{ TItemListBox }
function TItemListBox.AddItem(const ACaption: string; AChecked: Boolean;
ATag: NativeInt): Integer;
var
Item: TItem;
begin
Item := TItem.Create;
Item.Caption := ACaption;
Item.Checked := AChecked;
Item.OnChanged := ItemChanged;
Result := FItems.Add(Item);
InvalidateRect(Handle, ItemRect(Result), True);
end;
function TItemListBox.ClearButtonRect(Index: Integer): TRect;
begin
Result := Rect(CanvasWidth - 32, Index * FItemHeight, CanvasWidth,
(Index + 1) * FItemHeight);
end;
procedure TItemListBox.CMMouseLeave(var Message: TMessage);
begin
inherited;
StateChange(-1, ilbpText);
end;
constructor TItemListBox.Create(AOwner: TComponent);
begin
inherited;
FItems := TObjectList<TItem>.Create;
FItemHeight := 32;
FIndex := -1;
FMouseDownIndex := -1;
FFocusIndex := -1;
Color := clWindow;
TabStop := True;
end;
procedure TItemListBox.CreateDeviceResources;
begin
FreeAndNil(FCanvas);
FCanvas := TDirect2DCanvas.Create(Handle);
end;
procedure TItemListBox.CreateWnd;
begin
inherited;
CreateDeviceResources;
end;
destructor TItemListBox.Destroy;
begin
FreeAndNil(FItems);
FreeAndNil(FCanvas);
inherited;
end;
procedure TItemListBox.DrawClearButton(Index: Integer; Visible: Boolean; Hot: Boolean);
var
R: TRect;
begin
if not Visible then
Exit;
R := ClearButtonRect(Index);
InflateRect(R, -7, -7);
Canvas.Pen.Color := IfThen(Hot, clRed, clMaroon);
Canvas.Pen.Width := 2;
Canvas.MoveTo(R.Left, R.Top);
Canvas.LineTo(R.Right, R.Bottom);
Canvas.MoveTo(R.Right, R.Top);
Canvas.LineTo(R.Left, R.Bottom);
end;
procedure TItemListBox.DrawItem(Index: Integer; Item: TItem);
var
R: TRect;
S: string;
begin
// Background
Canvas.Brush.Color := clWindow;
Canvas.Brush.Style := bsSolid;
Canvas.Pen.Color := clWindowText;
Canvas.Pen.Width := 1;
Canvas.Pen.Style := psSolid;
R := ItemRect(Index);
Canvas.FillRect(R);
// Text
R := TextRect(Index);
S := Item.Caption;
Canvas.Font.Assign(Font);
Canvas.Font.Color := IfThen(Item.Checked, clGrayText, clWindowText);
if Item.Checked then
Canvas.Font.Style := [fsStrikeOut]
else
Canvas.Font.Style := [];
Canvas.TextRect(R, S, [tfSingleLine, tfEndEllipsis, tfVerticalCenter]);
// Check box
DrawCheckBox(Index, Item, (FIndex = Index) and (FPart = ilbpCheckBox));
// Clear button
DrawClearButton(Index, FIndex = Index, (FIndex = Index) and (FPart = ilbpClearButton));
// Focus indicator
if InRange(FFocusIndex, 0, FItems.Count - 1) and Focused then
begin
Canvas.Pen.Color := clSilver;
Canvas.Pen.Width := 1;
Canvas.Pen.Style := psSolid;
Canvas.Brush.Style := bsClear;
R := TextRect(FFocusIndex);
InflateRect(R, 0, -2);
Canvas.Rectangle(R);
end;
end;
procedure TItemListBox.DrawCheckBox(Index: Integer; Item: TItem;
Hot: Boolean);
var
R: TRect;
begin
R := CheckBoxRect(Index);
InflateRect(R, -5, -5);
Canvas.Pen.Color := clSilver;
Canvas.Pen.Width := 1;
Canvas.Brush.Color := IfThen(Hot, clSilver, clWhite);
Canvas.Ellipse(R);
if Assigned(Item) and Item.Checked then
begin
Canvas.Pen.Color := clGreen;
Canvas.Pen.Width := 2;
Canvas.MoveTo(R.Left + R.Width div 5, R.Bottom - R.Height div 2);
Canvas.LineTo(R.Left + Round(R.Width / 2.5), R.Bottom - Round(R.Height / 3.8));
Canvas.LineTo(R.Right - Round(R.Width / 4.5), R.Top + R.Height div 5);
end;
end;
function TItemListBox.GetItem(Index: Integer): TItem;
begin
Result := FItems[Index];
end;
function TItemListBox.GetItemCount: Integer;
begin
Result := FItems.Count;
end;
procedure TItemListBox.HitTest(const P: TPoint; out Index: Integer;
out Part: TPart);
var
i: Integer;
Q: TPoint;
begin
Q.X := MulDiv(P.X, 96, Screen.PixelsPerInch);
Q.Y := MulDiv(P.Y, 96, Screen.PixelsPerInch);
for i := 0 to FItems.Count - 1 do
if ItemRect(i).Contains(Q) then
begin
Index := i;
if CheckBoxRect(i).Contains(Q) then
Part := ilbpCheckBox
else if ClearButtonRect(i).Contains(Q) then
Part := ilbpClearButton
else
Part := ilbpText;
Exit;
end;
Index := -1;
Part := ilbpText;
end;
procedure TItemListBox.ItemChanged(Sender: TObject);
begin
Invalidate;
end;
function TItemListBox.ItemRect(Index: Integer): TRect;
begin
Result := Rect(0, Index * FItemHeight, CanvasWidth, (Index + 1) * FItemHeight);
end;
procedure TItemListBox.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited;
case Key of
VK_DOWN:
if Succ(FFocusIndex) <= FItems.Count - 1 then
begin
Inc(FFocusIndex);
Invalidate;
end;
VK_UP:
if Pred(FFocusIndex) >= 0 then
begin
Dec(FFocusIndex);
Invalidate;
end;
VK_HOME:
if FFocusIndex <> 0 then
begin
FFocusIndex := 0;
Invalidate;
end;
VK_END:
if FFocusIndex <> FItems.Count - 1 then
begin
FFocusIndex := FItems.Count - 1;
Invalidate;
end;
VK_SPACE:
if InRange(FFocusIndex, 0, FItems.Count - 1) then
FItems[FFocusIndex].Checked := not FItems[FFocusIndex].Checked;
VK_DELETE:
if InRange(FFocusIndex, 0, FItems.Count - 1) then
RemoveItem(FFocusIndex);
end;
end;
procedure TItemListBox.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
if CanFocus then
SetFocus;
HitTest(Point(X, Y), FMouseDownIndex, FMouseDownPart);
if FFocusIndex <> FMouseDownIndex then
begin
FFocusIndex := FMouseDownIndex;
Invalidate;
end;
end;
procedure TItemListBox.MouseMove(Shift: TShiftState; X, Y: Integer);
var
NewIndex: Integer;
NewPart: TPart;
begin
inherited;
HitTest(Point(X, Y), NewIndex, NewPart);
StateChange(NewIndex, NewPart);
end;
procedure TItemListBox.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
var
Index: Integer;
Part: TPart;
begin
HitTest(Point(X, Y), Index, Part);
if (Index <> -1) and (Index = FMouseDownIndex) and (Button = mbLeft) then
begin
if (Part = ilbpCheckBox) and (Part = FMouseDownPart) then
FItems[Index].Checked := not FItems[Index].Checked
else if (Part = ilbpClearButton) and (Part = FMouseDownPart) then
RemoveItem(Index);
end;
end;
procedure TItemListBox.Paint;
var
i: Integer;
begin
Canvas.RenderTarget.Clear(D2D1ColorF(clWhite));
for i := 0 to FItems.Count - 1 do
DrawItem(i, FItems[i]);
end;
procedure TItemListBox.RemoveItem(AIndex: Integer);
begin
FItems.Delete(AIndex);
FFocusIndex := EnsureRange(FFocusIndex, 0, FItems.Count - 1);
Invalidate;
end;
procedure TItemListBox.StateChange(ANewIndex: Integer; ANewPart: TPart);
var
OldIndex: Integer;
OldPart: TPart;
begin
OldIndex := FIndex;
OldPart := FPart;
FIndex := ANewIndex;
FPart := ANewPart;
if FIndex = OldIndex then
begin
if FPart <> OldPart then
begin
if ilbpCheckBox in [FPart, OldPart] then
InvalidateRect(Handle, CheckBoxRect(FIndex), True);
if ilbpClearButton in [FPart, OldPart] then
InvalidateRect(Handle, ClearButtonRect(FIndex), True);
end;
end
else
begin
InvalidateRect(Handle, ItemRect(OldIndex), True);
InvalidateRect(Handle, ItemRect(FIndex), True);
end;
end;
function TItemListBox.CanvasHeight: Integer;
begin
Result := MulDiv(ClientHeight, 96, Screen.PixelsPerInch);
end;
function TItemListBox.CanvasWidth: Integer;
begin
Result := MulDiv(ClientWidth, 96, Screen.PixelsPerInch);
end;
function TItemListBox.CheckBoxRect(Index: Integer): TRect;
begin
Result := Rect(0, Index * FItemHeight, 32, (Index + 1) * FItemHeight);
end;
function TItemListBox.TextRect(Index: Integer): TRect;
begin
Result := Rect(40, Index * FItemHeight, CanvasWidth - 40,
(Index + 1) * FItemHeight);
end;
procedure TItemListBox.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
procedure TItemListBox.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
inherited;
Message.Result := Message.Result or DLGC_WANTARROWS;
end;
procedure TItemListBox.WMKillFocus(var Message: TWMKillFocus);
begin
inherited;
Invalidate;
end;
procedure TItemListBox.WMPaint(var Message: TWMPaint);
var
PaintStruct: TPaintStruct;
res: HRESULT;
begin
BeginPaint(Handle, PaintStruct);
try
if Assigned(FCanvas) then
begin
FCanvas.BeginDraw;
try
Paint;
finally
res := FCanvas.RenderTarget.EndDraw;
if res = D2DERR_RECREATE_TARGET then
CreateDeviceResources;
end;
end;
finally
EndPaint(Handle, PaintStruct);
end;
end;
procedure TItemListBox.WMSetFocus(var Message: TWMSetFocus);
begin
inherited;
Invalidate;
end;
procedure TItemListBox.WMSize(var Message: TWMSize);
var
S: TD2DSizeU;
begin
if Assigned(FCanvas) then
begin
S := D2D1SizeU(ClientWidth, ClientHeight);
ID2D1HwndRenderTarget(FCanvas.RenderTarget).Resize(S);
end;
Invalidate;
inherited;
end;
end.
Example (with a simple TEdit at the top):
But please notice that this is not a finished control; it's merely a very primitive sketch or prototype. It is not fully tested. In addition, a real control would have scrolling support and a keyboard interface. Since it is very late in Sweden right now, I don't really have time to add that at the moment.
Update: I added high-DPI support and a keyboard interface (up, down, home, end, space, delete):

delphi: how can I put Image in DBGrid Title?

How can I put Image in TDBGrid column heading?
I tried, but the image kept showing and kept disappearing when i put the mouse over the title.
procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
if Column.FieldName = order then
Begin
Column.Title.Font.Color := clBlue;
//if gdFixed in State then // didn't work.. I don't know why!!!
if Rect.Top < 30 then
ImageList1.Draw(DBGrid1.Canvas, Rect.Right-18, Rect.Top-18, 0);
end
else
Column.Title.Font.Color := clWindowText;
end;
You can use a interposer class for TDBGrid and override the DrawCell procedure.
type
TDBGrid = Class(DBGrids.TDBGrid)
private
FIcon:TIcon;
FImageList: TImageList;
procedure SetImageList(const Value: TImageList);
Destructor Destroy;override;
published
procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
Property Imagelist: TImageList read FImageList Write SetImageList;
End;
TForm2 = class(TForm)
.......
implementation
{$R *.dfm}
{ TDBGrid }
destructor TDBGrid.Destroy;
begin
if Assigned(FIcon) then FIcon.Free;
inherited;
end;
procedure TDBGrid.SetImageList(const Value: TImageList);
begin
FImageList := Value;
FreeAndNil(FIcon);
if Assigned(FImageList) then
begin
FIcon := TIcon.Create;
FImageList.GetIcon(0, FIcon);
end;
end;
procedure TDBGrid.DrawCell(ACol, ARow: Integer; ARect: TRect; AState: TGridDrawState);
var
L_Col: Integer;
begin
if dgIndicator in Options then
L_Col := ACol - 1
else
L_Col := ACol;
inherited;
if Assigned(FIcon) and (L_Col > -1) and (ARow = 0) and (Columns[L_Col].FieldName = 'ID') and (gdFixed in AState) then
begin
Canvas.Draw(ARect.Right - 18, ARect.Bottom - 18, FIcon);
//FImagelist.Draw(Canvas,ARect.Right - 18, ARect.Bottom - 18,0); // would cause more flickering
end;
end;
procedure TForm2.FormCreate(Sender: TObject);
begin
DBGrid1.DoubleBuffered := true;
DBGrid1.Imagelist := ImageList1;
ReportMemoryLeaksOnShutDown := true;
end;

how can i free a Tpanel That have a TbitBtn that calls to free the Tpanel

I create a Custom Tpanel and inside I put various Custom Components ...
procedure Panel_Comp(Location: TWinControl; NumOfComp: Integer;Left,Top,Height,width:Integer);
begin
MyPanel := TsPanel.Create(Conf);
MyPanel.Name := 'MyPanel' + IntToStr(NumOfComp);
MyPanel.Parent := Location;
MyPanel.Left := Left;
MyPanel.Top := Top;
MyPanel.Height := Height;
MyPanel.Width := width;
MyPanel.Caption := '';
end;
and i call it like this
Panel_Comp(Conf.ScrollBox1,1,8,10,70,322);
in the same logic i put inside the new panel other custom components including a tBitbtn the have a onclick event..
procedure BitBtn_Comp(Location: TWinControl; NumOfComp: Integer; Left,Top,Height,Width,ImageNum: Integer);
begin
MyBitBtn := TBitBtn.Create(Conf);
......
MyBitBtn.tag := NumOfComp;
MyBitBtn.OnClick:= Conf.CloseCurrentPanel;
end;
In the main Forn The TConf.CloseCurrentPanel;
procedure TConf.CloseCurrentPanel(Sender: TObject);
var
panelComp: TComponent;
begin
panelComp := FindComponentEx('Conf.MyPanel'+ IntToStr(TBitBtn(Sender).tag);
TPanel(panelComp).Free;
Application.ProcessMessages;
end;
When I call that I get access violation...
I think is something that I must free all the components inside the panel before free the panel but how I free the BitBtn before the panel and continue the action of the click event?
Here is the FindComponetEx function instead you need it...
function FindComponentEx(const Name: string): TComponent;
var
FormName: string;
CompName: string;
P: Integer;
Found: Boolean;
Form: TForm;
I: Integer;
begin
// Split up in a valid form and a valid component name
P := Pos('.', Name);
if P = 0 then
begin
raise Exception.Create('No valid form name given');
end;
FormName := Copy(Name, 1, P - 1);
CompName := Copy(Name, P + 1, High(Integer));
Found := False;
// find the form
for I := 0 to Screen.FormCount - 1 do
begin
Form := Screen.Forms[I];
// case insensitive comparing
if AnsiSameText(Form.Name, FormName) then
begin
Found := True;
Break;
end;
end;
if Found then
begin
for I := 0 to Form.ComponentCount - 1 do
begin
Result := Form.Components[I];
if AnsiSameText(Result.Name, CompName) then Exit;
end;
end;
Result := nil;
end;
The AV occurs because you are destroying a component (MyBitBtn) while it is still handling Windows messages. The solution is to postpone the destruction until later via PostMessage, similar to this:
unit Unit1;
interface
uses
Windows,
Messages,
SysUtils,
Variants,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
ExtCtrls,
StdCtrls;
const
UM_DESTROYPANEL = WM_APP + 623; // some "unique" number; UM = user message
type
TConf = class(TForm)
Panel1: TPanel;
Button1: TButton;
procedure Button1Click(Sender: TObject);
strict private
procedure UMDestroyPanel(var Message: TMessage); message UM_DESTROYPANEL;
public
{ Public-Deklarationen }
end;
var
Conf: TConf;
implementation
{$R *.dfm}
procedure TConf.Button1Click(Sender: TObject);
begin
PostMessage(Handle, UM_DESTROYPANEL, 0, 0);
end;
procedure TConf.UMDestroyPanel(var Message: TMessage);
begin
Panel1.Free;
end;
end.
If needed you can use wParam and lParam to pass through parameters like so:
procedure TConf.Button1Click(Sender: TObject);
begin
PostMessage(Handle, UM_DESTROYPANEL, WPARAM(Panel1), 0);
end;
procedure TConf.UMDestroyPanel(var Message: TMessage);
begin
TObject(Message.WParam).Free;
end;
EDIT:
In your situation I'd probably rewrite TConf.CloseCurrentPanel like this:
procedure TConf.CloseCurrentPanel(Sender: TObject);
var
panelComp: TComponent;
begin
panelComp := FindComponentEx('Conf.MyPanel'+ IntToStr(TBitBtn(Sender).Tag);
PostMessage(Handle, UM_DESTROYPANEL, WPARAM(panelComp), 0);
end;
Alternatively you can pass through the Tag (might be the better solution because there's less casting involved):
procedure TConf.CloseCurrentPanel(Sender: TObject);
begin
PostMessage(Handle, UM_DESTROYPANEL, TBitBtn(Sender).Tag, 0);
end;
procedure TConf.UMDestroyPanel(var Message: TMessage);
var
panelComp: TComponent;
begin
panelComp := FindComponentEx('Conf.MyPanel'+ IntToStr(Message.WParam));
panelComp.Free;
end;
AFAICT the Application.ProcessMessages isn't needed.
procedure TConf.CloseCurrentPanel(Sender: TObject);
var
panelComp: TComponent;
begin
panelComp := FindComponentEx('Conf.MyPanel'+ IntToStr(TBitBtn(Sender).tag);
//Where you need to determine 'PanelComp' if there are.
if Assigned(panelComp) and (PanelComp is TPanel) then
TPanel(panelComp).Free;
Application.ProcessMessages;
end;

How To Toggle The cell Colour And Text In A TStringGrid On And Off

I am running Lazarus v0.9.30 (32 bit compiler).
I have a TForm with a standard TStringGrid on it. The grid has the following properties set. RowCount = 5, ColumnCount = 5, FixedCols = 0, FixedRows = 0.
I Googled some code that showed me how to change the cell colour and add some text to the cell when a user clicks on a TStringGrid cell. All works fine and I have extended it slightly to toggle the color/text on and off on the GridClick event.
The questions I have are more to better understand the purpose behind some of the elements of the code.
There is an array of Foregroud (FG) and Background (BG) TColor objects. Are they there to store the cell color attributes that are set on the GridClick event, so if the DrawCell event needs to get triggered again for any reason the cell can redraw itself? Can you avoid using the array of TColors and just set the colour / text in the DrawCell event as required?
If you need to use the arrays, I would assume that dimensions must match the Grid.ColCount and Grid.RowCount (ie. set via the SetLength call in Form.Create)
Is there a way to detect that you are clicking outside of the 5 x 5 cells of the stringgrid (ie in the whitespace) and thus prevent the GridClick from calling the DrawCell event. No matter where you click you always get a valid value for Row and Col.
unit testunit;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs,
ExtCtrls, Menus, ComCtrls, Buttons, Grids, StdCtrls, Windows, Variants,
LCLType;
type
{ TForm1 }
TForm1 = class(TForm)
Grid: TStringGrid;
procedure FormCreate(Sender: TObject);
procedure GridClick(Sender: TObject);
procedure GridDrawCell(Sender: TObject; aCol, aRow: Integer;
aRect: TRect; aState: TGridDrawState);
end;
var
Form1: TForm1;
implementation
var
FG: array of array of TColor;
BG: array of array of TColor;
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
var
Col, Row: integer;
begin
// Set the sizes of the arrays
SetLength(FG, 5, 5);
SetLength(BG, 5, 5);
// Initialize with default colors
for Col := 0 to Grid.ColCount - 1 do begin
for Row := 0 to Grid.RowCount - 1 do begin
FG[Col, Row] := clBlack;
BG[Col, Row] := clWhite;
end;
end;
end;
procedure TForm1.GridDrawCell(Sender: TObject; aCol, aRow: Integer;
aRect: TRect; aState: TGridDrawState);
var
S: string;
begin
S := Grid.Cells[ACol, ARow];
// Fill rectangle with colour
Grid.Canvas.Brush.Color := BG[ACol, ARow];
Grid.Canvas.FillRect(aRect);
// Next, draw the text in the rectangle
Grid.Canvas.Font.Color := FG[ACol, ARow];
Grid.Canvas.TextOut(aRect.Left + 22, aRect.Top + 2, S);
end;
procedure TForm1.GridClick(Sender: TObject);
var
Col, Row: integer;
begin
Col := Grid.Col;
Row := Grid.Row;
// Set the cell color and text to be displayed
if (Grid.Cells[Col,Row] <> 'Yes') then
begin
BG[Col, Row] := rgb(131, 245, 44);
FG[Col, Row] := RGB(0, 0, 0);
Grid.Cells[Col, Row] := 'Yes'
end {if}
else
begin
BG[Col, Row] := rgb(255, 255, 255);
FG[Col, Row] := RGB(255, 255, 255);
Grid.Cells[Col, Row] := '';
end; {else}
end;
end.
If you set the AllowOutboundEvents to False, the OnClick event will be fired only when you click on a certain cell, not when you click on a whitespace. So if you use this property, you will always get valid cell coordinates when you click somewhere.
procedure TForm1.FormCreate(Sender: TObject);
begin
StringGrid1.AllowOutboundEvents := False;
...
end;
Another point is that you should use the OnPrepareCanvas event instead of OnDrawCell, because in OnDrawCell you would have to paint everything, including text rendering. With OnPrepareCanvas you just set the Brush.Color and Font.Color for each cell which is going to be rendered.
And, you don't need to use arrays, you can use the Objects like you did with your columns, but surely you can keep the colors in the arrays. In the following example I've used the Objects and there's also shown the usage of the OnPrepareCanvas event, but note that this example as well as yours from the question colorize all cells including the fixed ones:
type
TCellData = class(TObject)
private
FStateYes: Boolean;
FForeground: TColor;
FBackground: TColor;
public
property StateYes: Boolean read FStateYes write FStateYes;
property Foreground: TColor read FForeground write FForeground;
property Background: TColor read FBackground write FBackground;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
Col, Row: Integer;
CellData: TCellData;
begin
for Col := 0 to StringGrid1.ColCount - 1 do
for Row := 0 to StringGrid1.RowCount - 1 do
begin
CellData := TCellData.Create;
CellData.StateYes := False;
CellData.Foreground := clBlack;
CellData.Background := clWhite;
StringGrid1.Objects[Col, Row] := CellData;
end;
StringGrid1.AllowOutboundEvents := False;
end;
procedure TForm1.FormDestroy(Sender: TObject);
var
Col, Row: Integer;
begin
for Col := 0 to StringGrid1.ColCount - 1 do
for Row := 0 to StringGrid1.RowCount - 1 do
StringGrid1.Objects[Col, Row].Free;
end;
procedure TForm1.StringGrid1Click(Sender: TObject);
var
Col, Row: Integer;
CellData: TCellData;
begin
Col := StringGrid1.Col;
Row := StringGrid1.Row;
if StringGrid1.Objects[Col, Row] is TCellData then
begin
CellData := TCellData(StringGrid1.Objects[Col, Row]);
if CellData.StateYes then
begin
StringGrid1.Cells[Col, Row] := '';
CellData.StateYes := False;
CellData.Foreground := RGB(255, 255, 255);
CellData.Background := RGB(255, 255, 255);
end
else
begin
StringGrid1.Cells[Col, Row] := 'Yes';
CellData.StateYes := True;
CellData.Foreground := RGB(0, 0, 0);
CellData.Background := RGB(131, 245, 44);
end;
end;
end;
procedure TForm1.StringGrid1PrepareCanvas(sender: TObject; aCol, aRow: Integer;
aState: TGridDrawState);
var
CellData: TCellData;
begin
if StringGrid1.Objects[ACol, ARow] is TCellData then
begin
CellData := TCellData(StringGrid1.Objects[ACol, ARow]);
StringGrid1.Canvas.Brush.Color := CellData.Background;
StringGrid1.Canvas.Font.Color := CellData.Foreground;
end;
end;

Resources