I have to create Editboxes dynamically, which I am creating using loop (loop variable j). 5 components are created successfully, but in 6th component, array shows nil (in debugging process), i.e. nothing was created actually. Again 7th and 8th components are created successfully but 9th doesn't.
I have declared variables like-
sud,eud,fud,a,e,c,d,na,st1,st2,citye,statee,pinne,cn,cr,cb,ca: array [0..9] of TEdit;
crr,vcl: array [0..9] of TEdit;
All other components which I declared above are created successfully in that loop.
crr[j+3]:=tEdit.Create(coregroup[i]);
crr[j+3].Parent:=coregroup[i];
crr[j+3].Top:= 77;
crr[j+3].Left:=83+(j*57);
crr[j+3].Width:=17;
I am in the same situation with the code for last two days.
If more clarification is required, I may provide you.
The actual code is-
sud,eud,fud,a,e,c,d,na,st1,st2,citye,statee,pinne,cn,cr,cb,ca: array [0..9] of TEdit;
crr,vcl: array [0..9] of TEdit;
dud,leud,lfud,b,f,g,h,nal,st1l,st2l,cityel,stateel,pinnel,dt,cl,crl,cbl,cal,vce: array [0..9] of TLabel;
count,ppointer:integer;
rcaldt: array[0..5] of TDateTimePicker;
coregroup:array of TGroupBox;
var
i,j,kk,aa,x:integer;
divv:array[0..3] of Tlabel;
u,m,k:integer;
begin
k:=0;
m:=0;
//kk:=groupbox11.ControlCount-1;
SetLength(coregroup,5);
for i:=0 to count-1 do
begin
coregroup[i]:= tGroupbox.Create(groupbox11);
coregroup[i].Parent:=groupbox11;
coregroup[i].SetBounds(8+(i*223),140,x,170);
if ctvt.ItemIndex=0 then
coregroup[i].Caption:='C T'+ IntToStr((aa*i)+1)
else
coregroup[i].Caption:='V T'+ IntToStr((aa*i)+1);
cl[0]:= tLabel.Create(coregroup[i]);
cl[0].Parent:=coregroup[i];
cl[0].Top:= 20;
cl[0].Left:=8;
cl[0].Caption:= 'CORE';
cl[0].Font.Style := cl[0].Font.Style + [fsBold];
cbl[0]:= tLabel.Create(coregroup[i]);
cbl[0].Parent:=coregroup[i];
cbl[0].Top:= 50;
cbl[0].Left:=8;
cbl[0].Caption:= 'BURDEN';
cbl[0].Font.Style := cbl[0].Font.Style + [fsBold];
crl[0]:= tLabel.Create(coregroup[i]);
crl[0].Parent:=coregroup[i];
crl[0].Top:= 80;
crl[0].Left:=8;
crl[0].Caption:= 'RATIO';
crl[0].Font.Style := crl[0].Font.Style + [fsBold];
cal[0]:= tLabel.Create(coregroup[i]);
cal[0].Parent:=coregroup[i];
cal[0].Top:= 110;
cal[0].Left:=8;
cal[0].Caption:= 'ACLASS'; //cr,cb,ca
cal[0].Font.Style := cal[0].Font.Style + [fsBold];
vce[0]:= tLabel.Create(coregroup[i]);
vce[0].Parent:=coregroup[i];
vce[0].Top:= 140;
vce[0].Left:=8;
vce[0].Caption:= 'VCLASS'; //cr,cb,ca
vce[0].Font.Style := cal[0].Font.Style + [fsBold];
for j:=0 to ((StrToInt(ncorct.Text))-1) do
begin
if cn[j]=nil then
begin
cn[j]:=tEdit.Create(coregroup[i]);
cn[j].Parent:=coregroup[i];
cn[j].Top:= 17;
cn[j].Left:=52+(j*57);
cn[j].Width:=50;
cb[j]:=tEdit.Create(coregroup[i]);
cb[j].Parent:=coregroup[i];
cb[j].Top:= 47;
cb[j].Left:=71+(j*57);
cb[j].Width:=30;
cr[j]:=tEdit.Create(coregroup[i]);
cr[j].Parent:=coregroup[i];
cr[j].Top:= 77;
cr[j].Left:=56+(j*57);
cr[j].Width:=17;
ca[j]:=tEdit.Create(coregroup[i]);
ca[j].Parent:=coregroup[i];
ca[j].Top:= 107;
ca[j].Left:=61+(j*60);
ca[j].Width:=35;
divv[j]:=tLabel.Create(coregroup[i]);
divv[j].Parent:=coregroup[i] ;
divv[j].Top:=80;
divv[j].Left:=74+(j*57);
divv[j].Caption:='/';
crr[j]:=tEdit.Create(coregroup[i]);
crr[j].Parent:=coregroup[i];
crr[j].Top:= 77;
crr[j].Left:=83+(j*57);
crr[j].Width:=17;
vcl[j]:=tEdit.Create(coregroup[i]);
vcl[j].Parent:=coregroup[i];
vcl[j].Top:= 137;
vcl[j].Left:=61+(j*60);
vcl[j].Width:=35;
end
else
if cn[j+3]=nil then
begin
cn[j+3]:=tEdit.Create(coregroup[i]);
cn[j+3].Parent:=coregroup[i];
cn[j+3].Top:= 17;
cn[j+3].Left:=52+(j*57);
cn[j+3].Width:=50;
cb[j+3]:=tEdit.Create(coregroup[i]);
cb[j+3].Parent:=coregroup[i];
cb[j+3].Top:= 47;
cb[j+3].Left:=71+(j*57);
cb[j+3].Width:=30;
cr[j+3]:=tEdit.Create(coregroup[i]);
cr[j+3].Parent:=coregroup[i];
cr[j+3].Top:= 77;
cr[j+3].Left:=56+(j*57);
cr[j+3].Width:=17;
ca[j+3]:=tEdit.Create(coregroup[i]);
ca[j+3].Parent:=coregroup[i];
ca[j+3].Top:= 107;
ca[j+3].Left:=61+(j*60);
ca[j+3].Width:=35;
divv[j+3]:=tLabel.Create(coregroup[i]);
divv[j+3].Parent:=coregroup[i] ;
divv[j+3].Top:=80;
divv[j+3].Left:=74+(j*57);
divv[j+3].Caption:='/';
***crr[j+3]:=tEdit.Create(coregroup[i]);
crr[j+3].Parent:=coregroup[i];
crr[j+3].Top:= 77;
crr[j+3].Left:=83+(j*57);
crr[j+3].Width:=17;***
vcl[j+3]:=tEdit.Create(coregroup[i]);
vcl[j+3].Parent:=coregroup[i];
vcl[j+3].Top:= 137;
vcl[j+3].Left:=61+(j*60);
vcl[j+3].Width:=35;
end
else
begin
cn[j+6]:=tEdit.Create(coregroup[i]);
cn[j+6].Parent:=coregroup[i];
cn[j+6].Top:= 17;
cn[j+6].Left:=52+(j*57);
cn[j+6].Width:=50;
cb[j+6]:=tEdit.Create(coregroup[i]);
cb[j+6].Parent:=coregroup[i];
cb[j+6].Top:= 47;
cb[j+6].Left:=71+(j*57);
cb[j+6].Width:=30;
cr[j+6]:=tEdit.Create(coregroup[i]);
cr[j+6].Parent:=coregroup[i];
cr[j+6].Top:= 77;
cr[j+6].Left:=56+(j*57);
cr[j+6].Width:=17;
ca[j+6]:=tEdit.Create(coregroup[i]);
ca[j+6].Parent:=coregroup[i];
ca[j+6].Top:= 107;
ca[j+6].Left:=61+(j*60);
ca[j+6].Width:=35;
divv[j+3]:=tLabel.Create(coregroup[i]);
divv[j+3].Parent:=coregroup[i] ;
divv[j+3].Top:=80;
divv[j+3].Left:=74+(j*57);
divv[j+3].Caption:='/';
crr[j+6]:=tEdit.Create(coregroup[i]);
crr[j+6].Parent:=coregroup[i];
crr[j+6].Top:= 77;
crr[j+6].Left:=83+(j*57);
crr[j+6].Width:=17;
vcl[j+6]:=tEdit.Create(coregroup[i]);
vcl[j+6].Parent:=coregroup[i];
vcl[j+6].Top:= 137;
vcl[j+6].Left:=61+(j*60);
vcl[j+6].Width:=35;
end;
end;
end;
end
else
begin
one.Enabled:=false;
onem.Enabled:=false;
end;
end;
you compare with nil
if cn[j]=nil then
but did you initialize array variable CN with nil?
I do not see this.
I suppose that this is the problem
Related
In a 32-bit VCL Application in Windows 10 in Delphi 11 Alexandria, I show an INPUT DIALOG to the user:
var aNewFolderName: string := 'New Project Folder';
if Vcl.Dialogs.InputQuery('New Project Folder', 'Enter the name of the new Project Folder:', aNewFolderName) then
begin
// Todo: Create the folder if everything went OK, ELSE REPEAT the input action :-(
end;
Is there a way to VALIDATE the user's input BEFORE he clicks the OK button? (E.g., checking for not allowed characters, existing folder, etc.). Just repeating the whole input action in the case of invalid input AFTER the user clicked OK is not very smart and efficient:
var aNewFolderName: string := 'New Project Folder';
var InputIsValid: Boolean;
repeat
if Vcl.Dialogs.InputQuery('New Project Folder', 'Enter the name of the new Project Folder:', aNewFolderName) then
begin
InputIsValid := CheckInput(aNewFolderName);
if InputIsValid then CreateTheFolder(aNewFolderName);
end
else
BREAK;
until InputIsValid;
Also, with this method, there is no feedback for the user about the specific cause of any invalid input.
Although it is possible to solve this problem by using repeated dialogs, I don't think that is a particularly elegant solution from a UX perspective.
I'd rather make my own dialog and do something like this:
procedure TForm1.btnSetPasswordClick(Sender: TObject);
begin
var psw := '';
if SuperInput(
Self,
'Frog Simulator',
'Please enter the new frog password:',
psw,
function(const Text: string; out AErrorMessage: string): Boolean
begin
if Text.Length < 8 then
begin
AErrorMessage := 'The password''s length must be at least 8 characters.';
Exit(False);
end;
if not StrHasChrOfType(Text, TCharacter.IsLetter) then
begin
AErrorMessage := 'The password must contain at least one letter.';
Exit(False);
end;
if not StrHasChrOfType(Text, TCharacter.IsDigit) then
begin
AErrorMessage := 'The password must contain at least one digit.';
Exit(False);
end;
if not StrHasChrOfType(Text, TCharacter.IsPunctuation) then
begin
AErrorMessage := 'The password must contain at least one punctuation character.';
Exit(False);
end;
Result := True;
end)
then
lblNewPassword.Caption := psw;
end;
Here's the code:
unit SuperInputDlg;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;
type
TValidator = reference to function(const Text: string;
out AErrorMessage: string): Boolean;
TSuperInputForm = class(TForm)
lblCaption: TLabel;
shClient: TShape;
Edit: TEdit;
pbErrorIcon: TPaintBox;
lblError: TLabel;
Validator: TTimer;
btnOK: TButton;
btnCancel: TButton;
procedure FormCreate(Sender: TObject);
procedure pbErrorIconPaint(Sender: TObject);
procedure EditChange(Sender: TObject);
procedure ValidatorTimer(Sender: TObject);
procedure btnOKClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FErrorIcon: HICON;
FLIWSD: Boolean;
FValidator: TValidator;
function DoValidate: Boolean;
public
end;
function SuperInput(AOwnerForm: TCustomForm; const ACaption, AMainInstruction: string;
var AText: string; AValidator: TValidator = nil): Boolean;
implementation
{$R *.dfm}
function Scale(X: Integer): Integer;
begin
Result := MulDiv(X, Screen.PixelsPerInch, 96);
end;
procedure TSuperInputForm.btnOKClick(Sender: TObject);
begin
if DoValidate then
ModalResult := mrOK;
end;
function TSuperInputForm.DoValidate: Boolean;
begin
var LErrMsg: string;
var LIsValid := not Assigned(FValidator) or FValidator(Edit.Text, LErrMsg);
btnOK.Enabled := LIsValid;
if not LIsValid then
lblError.Caption := LErrMsg;
pbErrorIcon.Visible := not LIsValid;
lblError.Visible := not LIsValid;
Result := LIsValid;
end;
procedure TSuperInputForm.EditChange(Sender: TObject);
begin
Validator.Enabled := False;
Validator.Enabled := True;
end;
procedure TSuperInputForm.FormCreate(Sender: TObject);
var
ComCtl: HMODULE;
LoadIconWithScaleDown: function(hinst: HINST; pszName: LPCWSTR; cx: Integer;
cy: Integer; var phico: HICON): HResult; stdcall;
begin
ComCtl := LoadLibrary('ComCtl32.dll');
if ComCtl <> 0 then
begin
try
LoadIconWithScaleDown := GetProcAddress(ComCtl, 'LoadIconWithScaleDown');
if Assigned(LoadIconWithScaleDown) then
LoadIconWithScaleDown(0, IDI_ERROR, Scale(16), Scale(16), FErrorIcon);
finally
FreeLibrary(ComCtl);
end;
end;
FLIWSD := FErrorIcon <> 0;
if FErrorIcon = 0 then
FErrorIcon := LoadIcon(0, IDI_ERROR);
end;
procedure TSuperInputForm.FormDestroy(Sender: TObject);
begin
if FLIWSD then
DestroyIcon(FErrorIcon);
end;
procedure TSuperInputForm.pbErrorIconPaint(Sender: TObject);
begin
if FErrorIcon <> 0 then
DrawIconEx(pbErrorIcon.Canvas.Handle, 0, 0, FErrorIcon,
Scale(16), Scale(16), 0, 0, DI_NORMAL);
end;
procedure TSuperInputForm.ValidatorTimer(Sender: TObject);
begin
DoValidate;
end;
function SuperInput(AOwnerForm: TCustomForm; const ACaption, AMainInstruction: string;
var AText: string; AValidator: TValidator = nil): Boolean;
begin
var LFrm := TSuperInputForm.Create(AOwnerForm);
try
LFrm.Caption := ACaption;
LFrm.lblCaption.Caption := AMainInstruction;
LFrm.Edit.Text := AText;
LFrm.FValidator := AValidator;
LFrm.DoValidate;
Result := LFrm.ShowModal = mrOk;
if Result then
AText := LFrm.Edit.Text;
finally
LFrm.Free;
end;
end;
end.
and DFM:
object SuperInputForm: TSuperInputForm
Left = 0
Top = 0
Caption = 'Input Box'
ClientHeight = 166
ClientWidth = 469
Color = clBtnFace
Constraints.MaxHeight = 204
Constraints.MinHeight = 204
Constraints.MinWidth = 400
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -12
Font.Name = 'Segoe UI'
Font.Style = []
OldCreateOrder = False
Position = poOwnerFormCenter
OnCreate = FormCreate
OnDestroy = FormDestroy
DesignSize = (
469
166)
PixelsPerInch = 96
TextHeight = 15
object shClient: TShape
Left = 0
Top = 0
Width = 468
Height = 127
Anchors = [akLeft, akTop, akRight, akBottom]
Pen.Style = psClear
ExplicitWidth = 499
ExplicitHeight = 175
end
object lblCaption: TLabel
Left = 24
Top = 24
Width = 65
Height = 21
Caption = 'Input Box'
Font.Charset = DEFAULT_CHARSET
Font.Color = 10040064
Font.Height = -16
Font.Name = 'Segoe UI'
Font.Style = []
ParentFont = False
end
object pbErrorIcon: TPaintBox
Left = 24
Top = 88
Width = 16
Height = 16
OnPaint = pbErrorIconPaint
end
object lblError: TLabel
Left = 50
Top = 88
Width = 3
Height = 15
end
object Edit: TEdit
Left = 24
Top = 51
Width = 418
Height = 23
Anchors = [akLeft, akTop, akRight]
TabOrder = 0
OnChange = EditChange
ExplicitWidth = 449
end
object btnOK: TButton
Left = 286
Top = 133
Width = 75
Height = 25
Anchors = [akRight, akBottom]
Caption = 'OK'
Default = True
TabOrder = 1
OnClick = btnOKClick
ExplicitLeft = 317
ExplicitTop = 181
end
object btnCancel: TButton
Left = 367
Top = 133
Width = 75
Height = 25
Anchors = [akRight, akBottom]
Cancel = True
Caption = 'Cancel'
ModalResult = 2
TabOrder = 2
ExplicitLeft = 398
ExplicitTop = 181
end
object Validator: TTimer
OnTimer = ValidatorTimer
Left = 136
Top = 120
end
end
Please note that this is only a sketch I did in ten minutes -- in a real app, you'd spend a bit more time on this one.
Appendix 1
type
TChrTestFcn = function(C: Char): Boolean;
function StrHasChrOfType(const AText: string; ATestFcn: TChrTestFcn): Boolean;
begin
for var S in AText do
if ATestFcn(S) then
Exit(True);
Result := False;
end;
No, there is no way. But there are alternatives:
Look up InputQuery's code, write similar code and then make modifications where you want them (e.g. setting an OnChange handler for the TEdit). You'll notice it has been done in a quite simple way.
Design your own form for it, instead of (like InputQuery does) creating one on the fly:
You can either use your own logic for getting the user's choice and input when the form is closed, or
you set the form's ModalResult property (via code) anytime, and you can assign a ModalResult to each button (e.g. mrCancel), so it automatically sets the form's ModalResult property. Call your own form just as if it's MessageBox():
case MyForm.ShowModal() of
IDOK: begin
// User wants to proceed AND no error was found
end;
IDCANCEL: begin
// User gave up
end;
else
// Unexpected result
end;
For me it would make nearly no difference if any feedback is given with any form still visible or not, as long as it is given. And you can give it, because nothing keeps you from doing so:
var
aNewFolderName,
sErrorMsg: String;
begin
repeat
aNewFolderName:= 'New Project Folder';
// User cancelled: leaving loop
if not Vcl.Dialogs.InputQuery( 'New project folder', 'Enter the name of the new project folder:', aNewFolderName ) then break;
// Already errors before the attempt?
sErrorMsg:= CheckInput( aNewFolderName );
// Actual attempt, which may still go wrong for various reasons
if sErrorMsg= '' then sErrorMsg:= CreateTheFolder( aNewFolderName );
// Anything to report?
if sErrorMsg<> '' then begin
sErrorMsg:= sErrorMsg+ #13#10
+ 'Click "Retry" to try a different new project name.'+ #13#10
+ 'Click "Cancel" to not create any new project.';
if MessageBox( sErrorMsg, 'Error', MB_RETRYCANCEL )= IDCANCEL then break;
end else begin
break; // Otherwise we're done (CreateTheFolder was successful)
end;
until FALSE;
end;
The easiest and most versatile option is to write your own input dialog and either include the validation code in the dialog or alternatively pass a callback method that does the validation.
But to answer the question as you asked it:
"Is there a way to VALIDATE the user's input BEFORE he clicks the OK button?"
No, there is no way, as far as I know.
Thanks to the users who explicitly confirmed that there is no predesigned way to validate the input before the user clicks OK. Now the remaining question is: How to provide a meaningful and efficient feedback about the invalidation cause to the user? IMO, showing an ADDITIONAL error dialog does not meet these criteria. So I implemented a solution where the prompt is replaced by the validation error message in the reappearing InputQuery dialog:
procedure TformMain.menuitemCreateASubProjectGroupClick(Sender: TObject);
begin
var aNewFolderName: string := 'New Project Group';
var InputIsValid: Boolean;
var InputPrompt: string := 'Enter the name of the new Project Group:';
repeat
if Vcl.Dialogs.InputQuery('New Project Group', InputPrompt, aNewFolderName) then
begin
var NewPrompt: string;
InputIsValid := CheckInput(aNewFolderName, NewPrompt);
if not InputIsValid then
InputPrompt := NewPrompt
else
begin
CreateNewFolder(aNewFolderName);
end;
end
else
BREAK;
until InputIsValid;
end;
function PAIsFilenameValid(const AFilename: string; var errorchar: Char): Boolean;
begin
Result := True;
for var i := 1 to Length(AFilename) do
begin
if not System.IOUtils.TPath.IsValidFileNameChar(AFilename[i]) then
begin
errorchar := AFilename[i];
Result := False;
BREAK;
end;
end;
end;
function TformMain.CheckInput(const aNewFolderName: string; out aNewPrompt: string): Boolean;
begin
Result := True;
var errorchar: Char;
if Trim(aNewFolderName) = '' then
begin
aNewPrompt := 'Error: You must enter a Group name:';
Result := False;
end
else if not PAIsFilenameValid(aNewFolderName, errorchar) then
begin
aNewPrompt := 'Error: No illegal characters (' + errorchar + '):';
Result := False;
end;
// Todo: else...
end;
Example screenshots:
I use this code:
proc := TProcess.Create(nil);
strList := TStringList.Create;
proc.Executable := 'netsh.exe';
proc.Parameters.Add('wlan');
proc.Parameters.Add('show');
proc.Parameters.Add('all');
proc.Options := proc.Options + [poWaitOnExit, poUsePipes];
proc.Execute;
strList.LoadFromStream(proc.Output);
proc.Free;
strList.Free;
The problem is netsh stay on screen (black command window) and do not stop.
If I remove poUsePipes, I can see clearly that netsh do the right job, output is correct.
It works with this code. I've understood the first method (in my question) generate to many bytes in the output so i had a deadlock. Mercy to https://wiki.freepascal.org/Executing_External_Programs (french version for me)
const
READ_BYTES = 2048;
var
Form1: TForm1;
proc: TProcess;
strList: TStringList;
ms: TMemoryStream;
n: LongInt;
br: LongInt;
i: longint;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
ms:=TMemoryStream.Create;
br:=0;
proc := TProcess.Create(nil);
strList := TStringList.Create;
proc.Executable := 'netsh.exe';
proc.Parameters.Add('wlan');
proc.Parameters.Add('show');
proc.Parameters.Add('all');
proc.Options := proc.Options + [poUsePipes];
proc.ShowWindow:=TShowWindowOptions.swoHIDE;
proc.Execute;
while proc.Running do
begin
ms.SetSize(br + READ_BYTES);
n:=proc.Output.Read((ms.Memory + br)^, READ_BYTES);
if n > 0
then begin
Inc(br, n);
end
else begin
//no data: wait 100ms
Sleep(100);
end;
end;
//read last part
repeat
ms.SetSize(br + READ_BYTES);
n:=proc.Output.Read((ms.Memory + br)^, READ_BYTES);
if n > 0
then begin
Inc(br, n);
end
until n <= 0;
ms.SetSize(br);
strList.LoadFromStream(ms);
proc.Free;
for i := 0 to strList.Count - 1 do
begin
memo.Append(CP437ToUTF8(strList.Strings[i]));
end;
strList.Free;
end;
I found that the gettickdiff64 function sometimes results in 18446744073709551600 (or 18446744073709551601) and causes the
program to run incorrectly.
Normally does not have a result greater than 300000
what might this be about?
Should I always do extra checks against this problem?
it is 32 bit VCL application.
I use Delphi 10.4.1( its indy version 10.6.2.0 )
Running on: 64 bit Windows Server 2012 R2 Foundation / intel xeon cpu E3-1225 v5 3.3 Ghz.
The code structure is as follows:
TMyClass = class
private
//.............
lastSetTime: uint64;
critic: TCriticalSection;
public
//.............
procedure setLastSetTime( ltime: uint64 );
function getLastSetTime: uint64;
end;
procedure TMyClass.setLastSetTime( ltime: uint64 );
begin
critic.enter;
try
lastSetTime := ltime;
finally
critic.leave;
end;
end;
function TMyClass.getLastSetTime: uint64;
begin
critic.enter;
try
result := lastSetTime;
finally
critic.leave;
end;
end;
...........
procedure controlAll(); //------>this is called from within thread every 5 minutes
var oki: boolean;
starttime, tdiff, ltime: uint64;
i: integer;
myC, sC: TMyClass;
begin
oki := false;
starttime := ticks64();
while ( oki = false ) and ( gettickdiff64( starttime, ticks64 ) < 40000 ) do
begin
//.........
//.........
sC := nil;
with myClassList.LockList do
try
if count > 0 then //---> has about 50000
begin
i := 0;
while i < count do
begin
myC := TMyClass( items[ i ] );
ltime := myC.getLastSetTime();
tdiff := gettickdiff64( ltime, ticks64() );
if tdiff > 50000 then
begin
logToFile( tdiff.ToString + ' ' + ltime.ToString ); //-----> every 5 minutes 50-60 log lines occur like this: 18446744073709551600 468528329
//..........
//.........
sC := myC;
delete( i );
break;
end;
inc( i );
end;
end;
finally
myClassList.UnlockList;
end;
if sC = nil then oki := true
else
begin
//..........
//..........
end;
end;
end;
The code structure that sets this value is as follows.
classListArray keeps all classes of TMyClass type grouped by server and channel number.
myClassList keeps all classes of type TMyClass attached one after the other without grouping.
classListArray is used to spend less CPU and process faster.
These two lists are not protected against each other when accessing classes.
Protection against each other is done only when adding and deleting classes.
classListArray: array[ 1..250, 1..12 ] of TThreadList;
//.................
procedure ServerExecute(AContext: TIdContext);
var Ath: TMypeer;
severNum, channelNum, clientNum, i, j, num: integer;
pSize: word;
stream: Tmemorystream;
packageNum: byte;
begin
try
Ath := TMypeer( AContext );
serverNum := Ath.getServerNum();
channelNum := Ath.getChannelNum();
Ath.SendQueue();
if AContext.Connection.IOHandler.InputBufferIsEmpty then
if not AContext.Connection.IOHandler.CheckForDataOnSource( 50 ) then Exit;
clientNum := AContext.Connection.IOHandler.ReadInt32( false );
pSize := AContext.Connection.IOHandler.ReadUInt16( false );
stream := TMemorystream.create;
try
AContext.Connection.IOHandler.ReadStream( stream, pSize );
stream.Seek( 0, soFromBeginning );
if clientNum <> 0 then
begin
//...........
end
else
begin
stream.ReadBuffer( packageNum, sizeof( packageNum ) );
if packageNum = 10 then
begin
stream.ReadBuffer( num, sizeof( num ) );
for i := 1 to num do
begin
stream.ReadBuffer( clientNum, sizeof( clientNum ) );
with classListArray[ serverNum, channelNum ].LockList do
try
if count > 0 then
for j := 0 to count - 1 do
begin
if TMyClass( items[ j ] ).getClientNum = clientNum then
begin
TMyClass( items[ j ] ).setLastSetTime( ticks64 ); //**********
break;
end;
end;
finally
classListArray[ serverNum, channelNum ].unLockList;
end;
end;
end
else
//.........
end;
finally
stream.free;
end;
except on e:exception do
begin
if E is Eidexception then raise
else
begin
logToFile( e.message );
//..........
end;
end;
end;
end;
According to your log, ltime was 468528329 and GetTickDiff64(ltime, Ticks64()) returned 18446744073709551600. Given the simple implementation of GetTickDiff64() (where TIdTicks is UInt64):
function GetTickDiff64(const AOldTickCount, ANewTickCount: TIdTicks): TIdTicks;
{$IFDEF USE_INLINE}inline;{$ENDIF}
begin
{This is just in case the TickCount rolled back to zero}
if ANewTickCount >= AOldTickCount then begin
Result := TIdTicks(ANewTickCount - AOldTickCount);
end else begin
Result := TIdTicks(((High(TIdTicks) - AOldTickCount) + ANewTickCount) + 1);
end;
end;
The only way this code can return 18446744073709551600 given AOldTickCount=468528329 is if ANewTickCount is either 18446744074178079929 or 468528313.
Since VCL runs on Windows only, and on Windows Ticks64() is just a thin wrapper around the Win32 GetTickCount64() function on Vista and later, it is very unlikely that Windows would ever produce such an astronomically large number like 18446744074178079929 for the current tick counter (that would be 213503982340 days from bootup). So it must have returned 468528313 instead, which is more reasonable (that is just 5.4 days from bootup). That is 16ms less than ltime=468528329, so GetTickDiff64() would assume that Windows' tick counter had exceeded High(UInt64) and wrapped back around to 0 (which is unlikely for a 64-bit tick counter to ever do in our lifetime).
So, you need to debug your code and figure out how Ticks64()/Windows could possibly return 468528329 and then later return 468528313. I suspect it is really not doing that, and that there is more likely a bug in your code that we can't see which is storing the wrong value into TMyClass.lastSetTime to begin with.
That being said, you might consider getting rid of the overhead of TCriticalSection and use TInterlocked instead to read/write your UInt64 member atomically.
Or, try using Delphi's own TStopWatch instead of tracking ticks manually.
program GameMain;
uses SwinGame, sgTypes;
function buttonClicked(p1, Next_PARAM_thingie: Single; W, lastOne: Integer): Boolean;
var blah, blee: Single; _r_, BTMOB: Single;
begin blah := MouseX(); blee := MouseY(); _r_ := p1 + W; BTMOB := Next_PARAM_thingie + lastOne; result := false;
if MouseClicked( LeftButton ) then
begin
if (blah >= p1) and (blah <= _r_) then
begin result := true;
end;
end;
end;
procedure Main();
var
clr: Color;
begin
OpenGraphicsWindow('Test Program for Button Click Code', 800, 600);
ShowSwinGameSplashScreen();
clr := ColorWhite;
repeat
clearScreen(clr);
drawframerate(0,0);
fillRectangle(ColorGrey, 50, 50, 100, 30);
drawtext('Click Me', ColorBlack, 'arial.ttf', 14, 55, 55);
RefreshScreen();
Processevents();
if buttonClicked(50, 50, 100, 30) then
begin
clr := RandomRGBcolor(255);
end;
until WindowCloseRequested();
end;
begin
main();
end.
I have been trying to figure out what does what but it isn't going to well. I could use some help trying to figure out what each of these random words do so I can change the name so the code is more understanding
The first thing that I would do is work through removing things that are unneeded. In the code sample given, BTMOB is entirely unused, so I would remove it and the code that sets its value. With BTMOB removed, the lastOne parameter is no longer needed, so it goes away.
Keep chipping away things that don't belong at all and using whatever context clues are available to give things that are used more meaningful names. There will be some things that you may not be able to guess just by analyzing the code and potentially not even through runtime debugging, but you should be able to make it far more readable. Here's an example of how buttonClicked might look after the first pass (you'd also have to change the code that calls it to no longer pass the unused parameters that were removed).
function buttonClicked(p1: Single; W: Integer): Boolean;
var posX: Single; _r_: Single;
begin posX := MouseX(); _r_ := p1 + W; result := false;
if MouseClicked( LeftButton ) then
begin
if (posX >= p1) and (posX <= _r_) then
begin result := true;
end;
end;
end;
Please see the attached screenshot which illustrates a TToolBar from one of my programs:
Notice the last two images of the Toolbar, they are disabled. The way they have been drawn to appear disabled is not very appealing, in fact in the Delphi IDE some of the images look the same.
The issue I have with it is I want my application to look a lot cleaner. The way the disabled items are drawn doesn't look very good. The TToolBar allows to set a disabled TImageList, I tried making my images black & white but they didn't look right, and would rather not have to always make the images black and white (time and effort). This problem also shows in my menus and popup menus, which don't allow for disabled images anyway.
Is there a way to paint the disabled items to look better on the eye?
If possible I would rather not look to use 3rd Party Controls. I know the Jedi Components allow disabled images for the menu etc, but would prefer a way to not resort too 3rd Party Components, when possible I would much prefer to use the standard issue VCL, especially as sometimes I use the TActionMainMenuBar to draw Office Style menus, which match the TToolBar when DrawingStyle is set to gradient.
EDIT
I have accepted RRUZ's answer, is it possible though to accept David's answer as well, both are very good answers and would like the answer to be shared between them if possible.
Thanks.
Sometime Ago i wrote a patch to fix this behavior. the key is patch the code of the TCustomImageList.DoDraw function, the technique used is similar to the used by the delphi-nice-toolbar app, but instead of patch a bpl IDE in this case we patch the function in memory.
Just include this unit in your project
unit uCustomImageDrawHook;
interface
uses
Windows,
SysUtils,
Graphics,
ImgList,
CommCtrl,
Math;
implementation
type
TJumpOfs = Integer;
PPointer = ^Pointer;
PXRedirCode = ^TXRedirCode;
TXRedirCode = packed record
Jump: Byte;
Offset: TJumpOfs;
end;
PAbsoluteIndirectJmp = ^TAbsoluteIndirectJmp;
TAbsoluteIndirectJmp = packed record
OpCode: Word;
Addr: PPointer;
end;
TCustomImageListHack = class(TCustomImageList);
var
DoDrawBackup : TXRedirCode;
function GetActualAddr(Proc: Pointer): Pointer;
begin
if Proc <> nil then
begin
if (Win32Platform = VER_PLATFORM_WIN32_NT) and (PAbsoluteIndirectJmp(Proc).OpCode = $25FF) then
Result := PAbsoluteIndirectJmp(Proc).Addr^
else
Result := Proc;
end
else
Result := nil;
end;
procedure HookProc(Proc, Dest: Pointer; var BackupCode: TXRedirCode);
var
n: DWORD;
Code: TXRedirCode;
begin
Proc := GetActualAddr(Proc);
Assert(Proc <> nil);
if ReadProcessMemory(GetCurrentProcess, Proc, #BackupCode, SizeOf(BackupCode), n) then
begin
Code.Jump := $E9;
Code.Offset := PAnsiChar(Dest) - PAnsiChar(Proc) - SizeOf(Code);
WriteProcessMemory(GetCurrentProcess, Proc, #Code, SizeOf(Code), n);
end;
end;
procedure UnhookProc(Proc: Pointer; var BackupCode: TXRedirCode);
var
n: Cardinal;
begin
if (BackupCode.Jump <> 0) and (Proc <> nil) then
begin
Proc := GetActualAddr(Proc);
Assert(Proc <> nil);
WriteProcessMemory(GetCurrentProcess, Proc, #BackupCode, SizeOf(BackupCode), n);
BackupCode.Jump := 0;
end;
end;
procedure Bitmap2GrayScale(const BitMap: TBitmap);
type
TRGBArray = array[0..32767] of TRGBTriple;
PRGBArray = ^TRGBArray;
var
x, y, Gray: Integer;
Row : PRGBArray;
begin
BitMap.PixelFormat := pf24Bit;
for y := 0 to BitMap.Height - 1 do
begin
Row := BitMap.ScanLine[y];
for x := 0 to BitMap.Width - 1 do
begin
Gray := (Row[x].rgbtRed + Row[x].rgbtGreen + Row[x].rgbtBlue) div 3;
Row[x].rgbtRed := Gray;
Row[x].rgbtGreen := Gray;
Row[x].rgbtBlue := Gray;
end;
end;
end;
//from ImgList.GetRGBColor
function GetRGBColor(Value: TColor): DWORD;
begin
Result := ColorToRGB(Value);
case Result of
clNone:
Result := CLR_NONE;
clDefault:
Result := CLR_DEFAULT;
end;
end;
procedure New_Draw(Self: TObject; Index: Integer; Canvas: TCanvas; X, Y: Integer; Style: Cardinal; Enabled: Boolean);
var
MaskBitMap : TBitmap;
GrayBitMap : TBitmap;
begin
with TCustomImageListHack(Self) do
begin
if not HandleAllocated then Exit;
if Enabled then
ImageList_DrawEx(Handle, Index, Canvas.Handle, X, Y, 0, 0, GetRGBColor(BkColor), GetRGBColor(BlendColor), Style)
else
begin
GrayBitMap := TBitmap.Create;
MaskBitMap := TBitmap.Create;
try
GrayBitMap.SetSize(Width, Height);
MaskBitMap.SetSize(Width, Height);
GetImages(Index, GrayBitMap, MaskBitMap);
Bitmap2GrayScale(GrayBitMap);
BitBlt(Canvas.Handle, X, Y, Width, Height, MaskBitMap.Canvas.Handle, 0, 0, SRCERASE);
BitBlt(Canvas.Handle, X, Y, Width, Height, GrayBitMap.Canvas.Handle, 0, 0, SRCINVERT);
finally
GrayBitMap.Free;
MaskBitMap.Free;
end;
end;
end;
end;
procedure HookDraw;
begin
HookProc(#TCustomImageListHack.DoDraw, #New_Draw, DoDrawBackup);
end;
procedure UnHookDraw;
begin
UnhookProc(#TCustomImageListHack.DoDraw, DoDrawBackup);
end;
initialization
HookDraw;
finalization
UnHookDraw;
end.
and the result will be
I submitted a QC report for a related issue over a year ago, but that was for menus. I've never seen this for TToolbar since it is a wrapper to the common control and the drawing is handled by Windows.
However, the images you are seeing are clearly as result of the VCL calling TImageList.Draw and passing Enabled=False – nothing else looks that bad! Are you 100% sure this really is a TToolbar?
The fix will surely be to avoid TImageList.Draw and call ImageList_DrawIndirect with the ILS_SATURATE.
You may need to modify some VCL source. First find the location where the toolbar is being custom drawn and call this routine instead of the calls to TImageList.Draw.
procedure DrawDisabledImage(DC: HDC; ImageList: TCustomImageList; Index, X, Y: Integer);
var
Options: TImageListDrawParams;
begin
ZeroMemory(#Options, SizeOf(Options));
Options.cbSize := SizeOf(Options);
Options.himl := ImageList.Handle;
Options.i := Index;
Options.hdcDst := DC;
Options.x := X;
Options.y := Y;
Options.fState := ILS_SATURATE;
ImageList_DrawIndirect(#Options);
end;
An even better fix would be to work out why the toolbar is being custom drawn and find a way to let the system do it.
EDIT 1
I've looked at the Delphi source code and I'd guess that you are custom drawing the toolbar, perhaps because it has a gradient. I never even knew that TToolbar could handle custom drawing but I'm just a plain vanilla kind of guy!
Anyway, I can see code in TToolBar.GradientDrawButton calling the TImageList.Draw so I think the explanation above is on the right track.
I'm fairly sure that calling my DrawDisabledImage function above will give you better results. If could find a way to make that happen when you call TImageList.Draw then that would, I suppose, be the very best fix since it would apply wholesale.
EDIT 2
Combine the function above with #RRUZ's answer and you have an excellent solution.
Solution from #RRUZ dosn't work if you use LargeImages in ActionToolBar. I made changes to the #RRUZ code to work with LargeImages in ActionToolBar.
unit unCustomImageDrawHook;
interface
uses
Windows,
SysUtils,
Graphics,
ImgList,
CommCtrl,
Math,
Vcl.ActnMan,
System.Classes;
implementation
type
TJumpOfs = Integer;
PPointer = ^Pointer;
PXRedirCode = ^TXRedirCode;
TXRedirCode = packed record
Jump: Byte;
Offset: TJumpOfs;
end;
PAbsoluteIndirectJmp = ^TAbsoluteIndirectJmp;
TAbsoluteIndirectJmp = packed record
OpCode: Word;
Addr: PPointer;
end;
TCustomImageListHack = class(TCustomImageList);
TCustomActionControlHook = class(TCustomActionControl);
var
DoDrawBackup : TXRedirCode;
DoDrawBackup2 : TXRedirCode;
function GetActualAddr(Proc: Pointer): Pointer;
begin
if Proc <> nil then
begin
if (Win32Platform = VER_PLATFORM_WIN32_NT) and (PAbsoluteIndirectJmp(Proc).OpCode = $25FF) then
Result := PAbsoluteIndirectJmp(Proc).Addr^
else
Result := Proc;
end
else
Result := nil;
end;
procedure HookProc(Proc, Dest: Pointer; var BackupCode: TXRedirCode);
var
n: SIZE_T;
Code: TXRedirCode;
begin
Proc := GetActualAddr(Proc);
Assert(Proc <> nil);
if ReadProcessMemory(GetCurrentProcess, Proc, #BackupCode, SizeOf(BackupCode), n) then
begin
Code.Jump := $E9;
Code.Offset := PAnsiChar(Dest) - PAnsiChar(Proc) - SizeOf(Code);
WriteProcessMemory(GetCurrentProcess, Proc, #Code, SizeOf(Code), n);
end;
end;
procedure UnhookProc(Proc: Pointer; var BackupCode: TXRedirCode);
var
n: SIZE_T;
begin
if (BackupCode.Jump <> 0) and (Proc <> nil) then
begin
Proc := GetActualAddr(Proc);
Assert(Proc <> nil);
WriteProcessMemory(GetCurrentProcess, Proc, #BackupCode, SizeOf(BackupCode), n);
BackupCode.Jump := 0;
end;
end;
procedure Bitmap2GrayScale(const BitMap: TBitmap);
type
TRGBArray = array[0..32767] of TRGBTriple;
PRGBArray = ^TRGBArray;
var
x, y, Gray: Integer;
Row : PRGBArray;
begin
BitMap.PixelFormat := pf24Bit;
for y := 0 to BitMap.Height - 1 do
begin
Row := BitMap.ScanLine[y];
for x := 0 to BitMap.Width - 1 do
begin
Gray := (Row[x].rgbtRed + Row[x].rgbtGreen + Row[x].rgbtBlue) div 3;
Row[x].rgbtRed := Gray;
Row[x].rgbtGreen := Gray;
Row[x].rgbtBlue := Gray;
end;
end;
end;
//from ImgList.GetRGBColor
function GetRGBColor(Value: TColor): DWORD;
begin
Result := ColorToRGB(Value);
case Result of
clNone:
Result := CLR_NONE;
clDefault:
Result := CLR_DEFAULT;
end;
end;
procedure New_Draw(Self: TObject; Index: Integer; Canvas: TCanvas; X, Y: Integer; Style: Cardinal; Enabled: Boolean);
var
MaskBitMap : TBitmap;
GrayBitMap : TBitmap;
begin
with TCustomImageListHack(Self) do
begin
if not HandleAllocated then Exit;
if Enabled then
ImageList_DrawEx(Handle, Index, Canvas.Handle, X, Y, 0, 0, GetRGBColor(BkColor), GetRGBColor(BlendColor), Style)
else
begin
GrayBitMap := TBitmap.Create;
MaskBitMap := TBitmap.Create;
try
GrayBitMap.SetSize(Width, Height);
MaskBitMap.SetSize(Width, Height);
GetImages(Index, GrayBitMap, MaskBitMap);
Bitmap2GrayScale(GrayBitMap);
BitBlt(Canvas.Handle, X, Y, Width, Height, MaskBitMap.Canvas.Handle, 0, 0, SRCERASE);
BitBlt(Canvas.Handle, X, Y, Width, Height, GrayBitMap.Canvas.Handle, 0, 0, SRCINVERT);
finally
GrayBitMap.Free;
MaskBitMap.Free;
end;
end;
end;
end;
procedure New_Draw2(Self: TObject; const Location: TPoint);
var
ImageList: TCustomImageList;
DrawEnabled: Boolean;
LDisabled: Boolean;
begin
with TCustomActionControlHook(Self) do
begin
if not HasGlyph then Exit;
ImageList := FindImageList(True, LDisabled, ActionClient.ImageIndex);
if not Assigned(ImageList) then Exit;
DrawEnabled := LDisabled or Enabled and (ActionClient.ImageIndex <> -1) or
(csDesigning in ComponentState);
ImageList.Draw(Canvas, Location.X, Location.Y, ActionClient.ImageIndex,
dsTransparent, itImage, DrawEnabled);
end;
end;
procedure HookDraw;
begin
HookProc(#TCustomImageListHack.DoDraw, #New_Draw, DoDrawBackup);
HookProc(#TCustomActionControlHook.DrawLargeGlyph, #New_Draw2, DoDrawBackup2);
end;
procedure UnHookDraw;
begin
UnhookProc(#TCustomImageListHack.DoDraw, DoDrawBackup);
UnhookProc(#TCustomActionControlHook.DrawLargeGlyph, DoDrawBackup2);
end;
initialization
HookDraw;
finalization
UnHookDraw;
end.
Take a look at this Delphi IDE fix. Maybe you can mimic it's implementation.
Use TActionToolbar , TActionmanager , Timagelist
Set action managers image list to a Timagelist. and set Disabledimages to another imagelist