How to Load a DLL in multiple threads in Delphi? - windows

Maybe there is something that I missed, I can't figure what is happening here.
I'm trying to load the same DLL in multiple instances of a TThread Object.
Here is my DLL code:
library MyCalcFor32;
uses
SysUtils,
Classes,
uRunner in 'uRunner.pas';
Exports EVal;
{$R *.res}
begin
end.
This is the uRunner.pas:
unit uRunner;
interface
uses SysUtils,
Classes;
function EVal(Valor: WideString): WideString; stdcall; export;
implementation
function EVal(Value: WideString): WideString; stdcall; export;
begin
Result := Value+' xxx';
end;
initialization
finalization
end.
This is the program to Load the DLL:
procedure TfrmMain.FormCreate(Sender: TObject);
var I: Integer;
begin
SetLength(Threads, 10);
for I:= 0 to 9 do
begin
Threads[I] := TWorker.Create(Self.Handle, I+1, Memo1.Text, ExtractFilePath(ParamStr(0)));
end;
end;
procedure TfrmMain.btnExecuteThreadsClick(Sender: TObject);
var I: Integer;
begin
ClearMemos([MT1, MT2, MT3, MT4, MT5, MT6, MT7, MT8, MT9, MT10]);
for I:= 0 to 0 do //to 9, for multiple
begin
if Threads[I].Suspended then
Threads[I].Resume
else
ShowMessage('Thread already in execution');
end;
end;
procedure TWorker.Execute;
var I: Integer;
J: Cardinal;
Ret: WideString;
A,B,C: Extended;
begin
CoInitialize(nil);
try
LoadDll;
while not Terminated do
begin
if not (Suspended or Terminated) then
begin
A := 310132041025;
B := 17592186044416;
C := 0;
for I:= 0 to 10 do
begin
if (Terminated) then begin
Break;
end;
for J:= 0 to 9999999 do
begin
if (Terminated) then begin
Break;
end;
A:= Sqrt(A);
if A <= 0 then begin
A:= 310132041025;
end
else begin
A:= Math.Power(A, 2);
end;
C:= C + (B-34 / 4);
B:= B / 2;
if B <= 0 then begin
B:= 17592186044416;
end;
end;
Ret := FEvalProcAddress(FEValValue);
NotifyMainForm(Format('Evaluate %s, resulted in %s', [IntToStr(I), Ret]));
end;
Suspend;
end;
Sleep(5000);
end;
finally
CoUninitialize;
end;
end;
procedure TWorker.LoadDll;
begin
//GlobalLock.Enter;
//try
FDLLHandle := LoadLibraryA(PChar(FPathApp + 'MyCalcFor32.dll'));
//finally
// GlobalLock.Leave;
//end;
if GetLastError <> 0 then
begin
NotifyTerminateThread;
end
else
begin
FEvalProcAddress := GetProcAddress(FDLLHandle, PChar('EVal'));
if GetLastError <> 0 then
begin
NotifyTerminateThread;
end;
end;
end;
When I have only 1 thread, it works just fine, but when I use multiple threads It raises the following exception:
System Error. Code: 87.
Incorrect Parameter
Note: The above code is just for reproduction;
I am aware of WideString + AnsiString problem.

You are performing the error checking incorrectly. You are only meant to call GetLastError if the function fails. I expect that you are calling GetLastError after an API call that succeeded and not all API calls do SetLastError(0) when they return success. So you are picking up a stale error code that does not apply to the function call that you made.
To check for failure, for these functions, you need to examine the return value.
LoadLibrary reports failure by returning 0.
GetProcAddress reports failure by returning nil.
You have to read the documentation of the functions carefully, but this is a very common theme. Each Win32 API function may potentially handle errors differently. Read the docs for each function individually.

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

firemonkey threading on android show a black page

i used a httpd to request some data from internet
function requestToServer(lParamList: TStringList) : string;
var
userDataString : string;
lHTTP: TIdHTTP;
serverResponce : string;
aobj: ISuperObject;
begin
application.ProcessMessages;
TThread.CreateAnonymousThread(
procedure
begin
lHTTP := TIdHTTP.Create(nil);
try
serverResponce := lHTTP.Post('http://domain.com/mjson.php', lParamList);
application.ProcessMessages;
aobj:= SO(serverResponce);
try
X := aobj['dta'].AsArray;
Except
form2.Memo1.Lines.Add('errr');
end;
if aobj['result'].AsString = 'lr_102' then
begin
form2.Label3.Text:='Saved token expired.';
form2.Rectangle2.Visible:=true;
end
else if aobj['result'].AsString = 'lr_103' then
begin
form2.Label3.Text:='Auto login.';
//load device data
form2.allDeviceListData := X;
form2.Hide;
form1.show;
end;
// globalReachedServer:=true;
finally
lHTTP.Free;
lParamList.Free;
end;
TThread.Synchronize(nil,
procedure
begin
end);
end
).Start();
end;
but after reach this function
the application show a black page and dont do anything until manually close
how can i do a web request at the background and with out hanging on fire-monkey !?
what a bout using REST is it better to access web service's?
Your code is not thread-safe. Your thread is directly accessing UI controls without synchronizing with the main UI thread. That alone can cause problems.
Also, all of the variables declared in the var section of requestToServer() should be moved into the var section of the anonymous procedure instead, since requestToServer() does not use them, so they can be completely local to the thread instead. The only thing the anonymous procedure should be capturing is the lParamList content.
Try something more like this:
function requestToServer(lParamList: TStringList) : string;
var
Params: TStringList;
Thread: TThread;
begin
Params := TStringList.Create;
try
Params.Assign(lParamList);
except
Params.Free;
raise;
end;
TThread.CreateAnonymousThread(
procedure
var
lHTTP: TIdHTTP;
serverResponce : string;
aObj: ISuperObject;
begin
try
try
lHTTP := TIdHTTP.Create(nil);
try
serverResponce := lHTTP.Post('http://domain.com/mjson.php', lParamList);
aObj := SO(serverResponce);
if aObj['result'].AsString = 'lr_102' then
begin
TThread.Queue(nil,
procedure
begin
form2.Label3.Text := 'Saved token expired.';
form2.Rectangle2.Visible := true;
end
);
end
else if aObj['result'].AsString = 'lr_103' then
begin
X := aObj['dta'].AsArray;
TThread.Queue(nil,
procedure
begin
form2.Label3.Text := 'Auto login.';
//load device data
form2.allDeviceListData := X;
form2.Hide;
form1.show;
end
);
end;
// globalReachedServer := true;
finally
lHTTP.Free;
end;
finally
Params.Free;
end;
except
TThread.Queue(nil,
procedure
begin
form2.Memo1.Lines.Add('errr');
end
);
end;
end
).Start;
end;

Pascal Program toString not working

I am working on a Pascal program that works with sets without using the built in operations. However my toString function is not working and I cannot figure out why.
This is the main part of the program
unit isetADT; {// do not change this!}
interface
const
MAX_SIZE = 100; {// if needed, use value 100; arbitrary}
type
iset = record {// your type definition goes here}
arrayint:array[1..MAX_SIZE] of integer;
setsize:integer;
end;
procedure makeEmpty(var s:iset);
function isEmpty(s:iset):boolean;
function isMember(n:integer; s:iset):boolean;
function equals(s1,s2:iset):boolean;
function card(s:iset):integer; {// cardinality}
procedure add(n:integer; var s:iset); {// does nothing if n is already a member of s}
procedure remove(n:integer; var s:iset); {// does nothing if n is not in s}
procedure union(s1,s2:iset; var res:iset);
procedure intersect(s1,s2:iset; var res:iset);
procedure diff(s1,s2:iset; var res:iset); {// s1 - s2}
function toString(s:iset):ansistring;
implementation
{// your implementation code goes here}
procedure makeEmpty(var s:iset);
begin
{s:=[]; clears array, unneeded}
s.setsize:=0;
end;
function isEmpty(s:iset):boolean;
var
empty:boolean;
begin
empty:=false;
if s.setsize=0 then
empty:=true;
isEmpty:=empty;
end;
function isMember(n:integer; s:iset):boolean;
var
count:integer;
begin
member:=false;
if s.setsize>0 then
begin
for count:=1 to s.setsize do
begin
if s.arrayint[count]=n then
isMember:=true;
end;
end;
end;
function equals(s1,s2:iset):boolean;
var
equal:boolean;
count:integer;
begin
equal:=false;
if s1.setsize<>s2.setsize then
else
begin
for count:=1 to s1.setsize do
begin
if isMember(s1.arrayint[count],s2) then
equal:=true
else
equal:=false;
end;
end;
equals:=equal;
end;
function card(s:iset):integer; {// cardinality}
var
cardinality:integer;
begin
cardinality:=s.setsize;
end;
procedure add(n:integer; var s:iset);
begin
if isMember(n,s) then
{it is already in the set nothing is done}
else
begin
s.setsize:=s.setsize+1; {adds 1 to the size so that the new member can be added}
s.arrayint[s.setsize]:=n; {puts member in the newly created space}
end;
end;
procedure remove(n:integer; var s:iset);
var
newsize:integer;
count:integer;
count2:integer;
begin
{needed to keep size constant when it is being changed in nested loops}
newsize:=s.setsize;
if isMember(n,s) then
begin
for count:= 1 to newsize do
begin
if s.arrayint[count]=n then
begin
for count2:=1 to newsize do
begin
s.arrayint[count]:=s.arrayint[count+1]; {replaces the removed member}
end;
s.setsize:=s.setsize-1;{removes unneeded size}
end;
end;
end;
end;
procedure union(s1,s2:iset; var res:iset);
var
count:integer;
count2:integer;
begin
makeEmpty(res);
if equals(s1,s2) then
{they are the same, nothing is done}
else
begin
{takes a member of s2 and puts it res if it is not in s1 since res is the same as s1}
for count:=1 to s1.setsize do
begin
add(s1.arrayint[count],res);
end;
for count2:=1 to s2.setsize do
begin
add(s2.arrayint[count2],res);
end;
end;
end;
procedure intersect(s1,s2:iset; var res:iset);
var
count:integer;
begin
if equals(s1,s2) then
res:=s1 {since they are the same only 1 needs to be returned}
else
begin
for count:=1 to s1.setsize do
begin
{number is added to res if it is in both s1 AND s2 only}
if isMember(s1.arrayint[count],s2) then
add(s1.arrayint[count],res)
end;
end;
end;
procedure diff(s1,s2:iset; var res:iset);
var
member:boolean;
count:integer;
count2:integer;
begin
member:=false;
if equals(s1,s2) then
{if they are the same then nothing is returned because there is no difference}
makeEmpty(res)
else
begin
for count:=1 to s1.setsize do
begin
for count2:=1 to s2.setsize do
begin
{if number is in s1 and not s2 then it is true and it is added to res}
if s1.arrayint[count]=s2.arrayint[count2] then
member:=true;
end;
if member=false then
add(s1.arrayint[count],res);
end;
end;
end;
function toString(s:iset):ansistring; {this is just a string with no size limit}
var
print:ansistring;
x:string;
i: Integer;
count:integer;
begin
print:='';
for count:=1 to s.setsize do
begin
i:=s.arrayint[count];
str(i,x);
print:=print+x+',';
end;
print:='{'+ print+'}';
toString:=print;
end;
end. {END OF PROGRAM}
and this is the runner for the program
program testisetSample;
uses isetADT;
var
s1,s2,s3 : iset;
i : integer;
begin
makeEmpty(s1); makeEmpty(s2);
for i := 1 to 5 do
add(i,s1);
for i := 3 to 8 do
add(i,s2);
intersect(s1,s2,s3);
writeln(toString(s3));
readln;
end.
Obvious mistake:
You are using
print:=print+'x'+',';
when you want
print:=print+x+',';
Mistakes in isMember:
member:=false;
you are not setting isMember, the returned value will be "random". You could remove member altogether and always use `isMember?
if s.setsize=0 then
Should be > 0. But it is not needed

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 get the Windows version is Vista and up versus XP on Delphi?

Is there any way to know which verion of Windows we are working on?
I need to set image to TBitButton in Windows XP and no image in Windows7. It should be done automatically.
Check the SysUtils.Win32MajorVersion (in Delphi 7, you'll need to add SysUtils to your uses clause if it's not there already - later versions add it automatically). The easiest way is to assign the Glyph as usual in the IDE, and clear it if you're running on Vista or higher:
if SysUtils.Win32MajorVersion >= 6 then // Windows Vista or higher
BitBtn1.Glyph := nil;
For more info on detecting specific Windows editions and versions, see this post. It hasn't been updated for the latest Windows versions and editions, but it'll get you started. You can also search SO for [delphi] GetVersionEx to see other examples.
This is actually a little project of mine - a drop-in component which provides info of the operating system - even preview it in design-time...
unit JDOSInfo;
interface
uses
Classes, Windows, SysUtils, StrUtils, Forms, Registry;
type
TJDOSInfo = class(TComponent)
private
fReg: TRegistry;
fKey: String;
fMinor: Integer;
fMajor: Integer;
fBuild: Integer;
fPlatform: Integer;
fIsServer: Bool;
fIs64bit: Bool;
fProductName: String;
function GetProductName: String;
procedure SetProductName(Value: String);
procedure SetMajor(Value: Integer);
procedure SetMinor(Value: Integer);
procedure SetBuild(Value: Integer);
procedure SetPlatform(Value: Integer);
procedure SetIs64Bit(const Value: Bool);
procedure SetIsServer(const Value: Bool);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Major: Integer read fMajor write SetMajor;
property Minor: Integer read fMinor write SetMinor;
property Build: Integer read fBuild write SetBuild;
property Platf: Integer read fPlatform write SetPlatform;
property ProductName: String read GetProductName write SetProductName;
property IsServer: Bool read fIsServer write SetIsServer;
property Is64Bit: Bool read fIs64bit write SetIs64Bit;
end;
function IsWOW64: Boolean;
function GetOSInfo: TOSVersionInfo;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('JD Custom', [TJDOSInfo]);
end;
function GetOSInfo: TOSVersionInfo;
begin
FillChar(Result, SizeOf(Result), 0);
Result.dwOSVersionInfoSize := SizeOf(Result);
if not GetVersionEx(Result) then
raise Exception.Create('Error calling GetVersionEx');
end;
function IsWOW64: Boolean;
type
TIsWow64Process = function( // Type of IsWow64Process API fn
Handle: THandle;
var Res: BOOL): BOOL; stdcall;
var
IsWow64Result: BOOL; // result from IsWow64Process
IsWow64Process: TIsWow64Process; // IsWow64Process fn reference
begin
// Try to load required function from kernel32
IsWow64Process:= GetProcAddress(GetModuleHandle('kernel32'),'IsWow64Process');
if Assigned(IsWow64Process) then
begin
// Function is implemented: call it
if not IsWow64Process(GetCurrentProcess, IsWow64Result) then
raise Exception.Create('Bad process handle');
// Return result of function
Result := IsWow64Result;
end else
// Function not implemented: can't be running on Wow64
Result:= False;
end;
constructor TJDOSInfo.Create(AOwner: TComponent);
var
Info: TOSVersionInfo;
Str: String;
begin
inherited Create(AOwner);
fReg:= TRegistry.Create(KEY_READ);
fReg.RootKey:= HKEY_LOCAL_MACHINE;
fKey:= 'Software\Microsoft\Windows NT\CurrentVersion';
fReg.OpenKey(fKey, False);
Info:= GetOSInfo;
fMajor:= Info.dwMajorVersion;
fMinor:= Info.dwMinorVersion;
fBuild:= Info.dwBuildNumber;
fIsServer:= False;
fIs64bit:= False;
fPlatform:= Info.dwPlatformId;
if fMajor >= 5 then begin
//After 2000
if fReg.ValueExists('ProductName') then
Str:= fReg.ReadString('ProductName')
else begin
Str:= 'Unknown OS: '+IntToStr(fMajor)+'.'+IntToStr(fMinor)+'.'+
IntToStr(fBuild)+'.'+IntToStr(fPlatform);
end;
if fReg.ValueExists('InstallationType') then begin
if UpperCase(fReg.ReadString('InstallationType')) = 'SERVER' then
fIsServer:= True;
end;
fIs64bit:= IsWOW64;
if fIs64bit then
Str:= Str + ' 64 Bit';
end else begin
//Before 2000
case fMajor of
4: begin
case fMinor of
0: Str:= 'Windows 95';
10: Str:= 'Windows 98';
90: Str:= 'Windows ME';
end;
end;
else begin
Str:= 'Older than 95';
end;
end;
end;
Self.fProductName:= Str;
end;
destructor TJDOSInfo.Destroy;
begin
if assigned(fReg) then begin
if fReg.Active then
fReg.CloseKey;
fReg.Free;
end;
inherited Destroy;
end;
function TJDOSInfo.GetProductName: String;
begin
Result:= Self.fProductName;
end;
procedure TJDOSInfo.SetProductName(Value: String);
begin
//Do Nothing Here!
end;
procedure TJDOSInfo.SetMinor(Value: Integer);
begin
//Do Nothing Here!
end;
procedure TJDOSInfo.SetMajor(Value: Integer);
begin
//Do Nothing Here!
end;
procedure TJDOSInfo.SetBuild(Value: Integer);
begin
//Do Nothing Here!
end;
procedure TJDOSInfo.SetPlatform(Value: Integer);
begin
//Do Nothing Here!
end;
procedure TJDOSInfo.SetIs64Bit(const Value: Bool);
begin
//Do Nothing Here!
end;
procedure TJDOSInfo.SetIsServer(const Value: Bool);
begin
//Do Nothing Here!
end;
end.

Resources