I'm using Delphi 7 and the program I am writing needs to continuously draw on the screen. While it currently doesn't draw anything important, this is a necessity in the program later on. However, when I put the procedure for drawing the screen in a while loop which can only be stopped by pressing any button the program stops responding completely. I don't understand why this is happening. Surely, as the while loop can be exited, the program should continue to run fine.
Here is the source code:
unit DD04f1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, TeCanvas, ExtCtrls;
type
TForm1 = class(TForm)
Image1: TImage;
Button1: TButton;
procedure Image1OnCreate();
procedure ScreenRender();
procedure OnCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
IsDone : Boolean;
implementation
{$R *.dfm}
procedure TForm1.OnCreate(Sender: TObject);
begin
IsDone := False;
end;
procedure TForm1.Image1OnCreate ();
var
Count:Integer;
begin
image1.canvas.Create();
image1.canvas.Pen.Color:=clBlack;
image1.canvas.rectangle(0,0,640,480);
image1.canvas.Pen.Color:=$ed630e; //bgr instead of rgb
Count:=0;
While (Count <> 640) do
begin
image1.Canvas.moveto(Count,0);
image1.Canvas.LineTo(Count,480);
Count:=Count+1;
end;
end;
procedure TForm1.ScreenRender();
var
Count : Integer;
begin
Count:=0;
While(Count<>640) do
begin
image1.Canvas.moveto(Count,0);
image1.Canvas.LineTo(Count,480);
Count:=Count+1;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Image1OnCreate();
Button1.Visible := False;
While(IsDone = False) do
begin
ScreenRender();
end;
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
IsDone := True;
end;
end.
procedure TForm1.OnCreate(Sender: TObject);
begin
IsDone := False;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Image1OnCreate();
Button1.Visible := False;
While(IsDone = False) do
begin
ScreenRender();
end;
end;
Assuming IsDone is always False (because otherwise we would not enter the loop), this loop can not terminate. It is infinite.
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
IsDone := True;
end;
You do not call this procedure from inside TForm1.Button1Click loop, hence it can never be called after you entered that loop. Since you never exit the TForm1.Button1Click procedure you do not allow any outside agent (like messages dispatch loop in VCL) to get executed and call that procedure either. To sum it up as soon as you entered the loop there is no any executable code that can change IsDone value. So, it is not changed.
Event handlers are supposed to be very short procedures, executing almost immediately, and giving up "execution flow control" back to VCL internals. Every long (more so infinite) processing leads to the program becomes irresponsive. No matter how many news Windows might want to tell the program - the program never asks for them.
https://en.wikipedia.org/wiki/Event-driven_programming
https://msdn.microsoft.com/en-us/library/windows/desktop/ms644927.aspx
https://msdn.microsoft.com/en-us/library/windows/desktop/ms632593.aspx
It was once told that Windows windows (GDI objects) are living in the center of the "messages storm" that they have to work out in timely matter. Hundreds of those messages are incoming every second and a Window Procedure (built inside the VCL classes for Delphi 7 forms) should receive, dispatch, and process every one of them before it's too late.
As soon as you blocked that process by making one of event handlers long or even endless - you broke the basic contract between the OS and the application.
You have to do "inversion of control", to break your continuous work into small short chunks and make Windows call those chunks when it sees appropriate.
Try to use TTimer for example.
PS. A VERY remote problem you can look at:
How to use Pipeline pattern in Delphi
How to Stop all Pipeline tasks correctly
Skip all the multithreading stuff there, for your case it only is important that other threads create those "chunks of work" that we have to paint onto our forms when Windows asks us to do so at some reasonable framerate (not too fast and not too slow). Your work chunks are fundamentally different, so all the threading stuff unrelated to you.
And the rendering is made inside TTimer events. So the "framework" of setting up the timer, turning it on and off might be of some interest to you. However the work you are going to do inside the .OnTimer event would be significantly different (just painting something, or even merely invalidating some part of the form and waiting for the Windows to trigger OnPaint event.).
You already got an excellent answer why your current code does not work and in your comments you are mentioning you want to do ray casting and drawing from a players perspective, so I assume some kind of game background.
I'm not sure the VCL is the best basis for a game. Different philosophies and needs. As Arioch 'The explained Delphi's VCL is event driven. Things happen in response to windows messages, even painting. If nothing causes a need to repaint, nothing will be painted anew.
This is very different from how I understand game engines (I'm by no means an expert). Even if nothing happens, they will continuously draw frame after frame to present as fluid as possible. Each frame might include an update to underlying structures based on game rules, physics, player input, animation, but even when they remain the same a new frame will be drawn. Basically three steps happen in a simplified 'game loop'
Input
Update
Presentation
All this happens for every frame. There might be no input, no update of the game's structures or even no presentation is desired. But all three steps belong together, the input causing an update that is later presented happened in the exact same frame as the resulting drawing.
This is something I find hard to fit into the VCL. As a solution must be based on the existing VCL loop and windows messages. You basically attempted to create such a game loop in VCL.
A way to solve your immediate issue - that you want to present something based on a calculation - could be just using the principle of the VCL. You want to have something drawn. VCL controls normally communicate their desire to be drawn by Invalidate, causing their BoundsRect to be invalidated. You could do that after you have done your calculations. In the following example I'll just use a timer to simulate your calculations are done. Just be aware that Invalidate will cause WM_PAINT messages to be generated for the control, but will not cause immediate repainting. There might be messages queued before the WM_PAINT is processed.
I'm using a TPaintBox's OnPaint to actually do the painting work, you might want to have your own control for that in the future when your project progresses.
unit Unit2;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls;
type
TFormMain = class(TForm)
procedure FormCreate(Sender: TObject);
private
Timer1: TTimer;
PaintBox1: TPaintBox;
{ Private declarations }
procedure PaintBox1Paint(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
public
{ Public declarations }
end;
implementation
{$R *.dfm}
procedure TFormMain.FormCreate(Sender: TObject);
begin
PaintBox1 := TPaintBox.Create(Self);
PaintBox1.Parent := Self;
PaintBox1.Align := alClient;
PaintBox1.OnPaint := PaintBox1Paint;
Timer1 := TTimer.Create(Self);
Timer1.Interval := 100;
Timer1.OnTimer := Timer1Timer;
Randomize;
end;
procedure TFormMain.PaintBox1Paint(Sender: TObject);
var
AColor: TColor;
I: Integer;
begin
for I := 0 to PaintBox1.ClientWidth - 1 do
begin
AColor := RGB(Random(256), Random(256), Random(256));
PaintBox1.Canvas.Pen.Color := AColor;
PaintBox1.Canvas.MoveTo(I, 0);
PaintBox1.Canvas.LineTo(I, PaintBox1.ClientHeight);
end;
end;
procedure TFormMain.Timer1Timer(Sender: TObject);
begin
PaintBox1.Invalidate;
end;
end.
Related
I'm making use of a GDI+ canvas in Delphi 10.1 Berlin, using the built-in units GDIPAPI and GDIPOBJ. I have a thread which is performing drawing, and while looking for ways to improve the performance of the thread, one major drawback is the fact that I'm currently forced to instantiate an instance of this canvas (TGPGraphics), perform the drawing, and destroy the canvas, all together at the same time, at the moment I wish to draw. Instead, I would like to maintain a single constant instance of TGPGraphics.
Problem
The problem is that when I attempt to create a single global instance of TGPGraphics and use it in the future, for some reason it ends up drawing nothing onto the canvas. It results in just an empty unpainted canvas. It only works when I create/destroy the canvas at the exact moment I need to actually draw anything. I seem to be forced to create the instance, perform the painting, then destroy it, before I'm allowed to read that bitmap image.
The same problem happens elsewhere, not just inside the thread and not just on a TBitmap. I faced this issue in the past, but I was able to get away with constantly creating/freeing it for that project. This one though, it's not acceptable.
Question
How can I retain a single instance of TGPGraphics instead of creating/destroying it each time I need to draw?
Example
Here's a minimal test application which demonstrates the issue. Turn the GLOBAL_CANVAS conditional on and off - be sure to do a Build when changing, don't immediately go to Run. It's just a blank form with no components, just code:
unit uMain;
interface
{$DEFINE GLOBAL_CANVAS}
{$DEFINE FLUSH_SYNC}
{ $DEFINE FLUSH_BEFORE}
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
GDIPAPI, GDIPOBJ;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormResize(Sender: TObject);
private
FCan: TGPGraphics;
FPen: TGPPen;
FBmp: TBitmap;
function CreateCanvas: TGPGraphics;
procedure DoFlush;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
FBmp:= TBitmap.Create;
FBmp.Width:= ClientWidth;
FBmp.Height:= ClientHeight;
{$IFDEF GLOBAL_CANVAS}
FCan:= CreateCanvas;
{$ENDIF}
FPen:= TGPPen.Create(MakeColor(255, 0, 0));
FPen.SetWidth(4.0);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FPen.Free;
{$IFDEF GLOBAL_CANVAS}
FCan.Free;
{$ENDIF}
FBmp.Free;
end;
function TForm1.CreateCanvas: TGPGraphics;
begin
Result:= TGPGraphics.Create(FBmp.Canvas.Handle);
Result.SetInterpolationMode(InterpolationMode.InterpolationModeHighQuality);
Result.SetSmoothingMode(SmoothingMode.SmoothingModeHighQuality);
Result.SetCompositingQuality(CompositingQuality.CompositingQualityHighQuality);
end;
procedure TForm1.DoFlush;
begin
{$IFDEF FLUSH_SYNC}
FCan.Flush(FlushIntention.FlushIntentionSync);
{$ELSE}
FCan.Flush(FlushIntention.FlushIntentionFlush);
{$ENDIF}
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
{$IFNDEF GLOBAL_CANVAS}
FCan:= CreateCanvas;
try
{$ENDIF}
{$IFDEF FLUSH_BEFORE}
DoFlush;
{$ENDIF}
FCan.DrawEllipse(FPen, 5, 5, 50, 50);
{$IFNDEF FLUSH_BEFORE}
DoFlush;
{$ENDIF}
{$IFNDEF GLOBAL_CANVAS}
finally
FCan.Free;
end;
{$ENDIF}
Caption:= 'Handle: ' + IntToStr(FBmp.Canvas.Handle);
Canvas.Draw(0, 0, FBmp);
end;
procedure TForm1.FormResize(Sender: TObject);
begin
FBmp.Width:= ClientWidth;
FBmp.Height:= ClientHeight;
end;
end.
The left is when I create/free the canvas at the time of painting, and the right is when I create/free the canvas at startup/shutdown.
EDIT
I just noticed something - when GLOBAL_CANVAS is enabled in the test above, and then you resize the form to complete minimal size, then make it bigger again, you can see little bits and pieces of the drawing, but not the entire thing.
EDIT 2
I tried the recommendation to use Flush, and I switched it from FlushIntentionFlush to FlushIntentionSync, and now I have about a 50/50 success rate. Sometimes I run the app and it shows, and other times, making no changes at all, I run the app and nothing draws. I tried many different combinations of using Flush, using both methods, before drawing and after drawing. The few times it does appear to work, I resize the form to hide it, and make it larger again, and I can only see a glitchy image...
EDIT 3
I discovered the cause of the problem: the canvas handle keeps getting recreated, so each time I go to draw, the canvas has a whole new handle. I get the same behavior with both TForm.Canvas.Handle and TBitmap.Canvas.Handle. I'm not sure what the appropriate solution is though. I can't find a way to pass the new handle into the canvas object. The reason why it sometimes draws a glitchy image is because sometimes it obtains the same handle, but most of the time, it's different.
I'm trying to achieve a simple drag and drop-panel, where a user can drop a file from windows explorer. The basic functionality is already working after I found this Thread.
Now I'm trying to change the color of the panel, while the user is dragging a file over it. I tried to use OnDragOver, but nothing happens. What am I doing wrong?
This is my current code:
unit main;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ShellApi,
Vcl.ExtCtrls, Vcl.Imaging.pngimage;
type
TPanel = class(Vcl.ExtCtrls.TPanel)
protected
procedure WMDropFiles(var Message: TWMDropFiles); message WM_DROPFILES;
procedure CreateWnd; override;
procedure DestroyWnd; override;
end;
TfrmMain = class(TForm)
panFileDrop: TPanel;
lblFileName: TLabel;
procedure panFileDropDragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
frmMain: TfrmMain;
implementation
{$R *.dfm}
procedure TPanel.CreateWnd;
begin
inherited;
DragAcceptFiles(Handle, true);
end;
procedure TPanel.DestroyWnd;
begin
DragAcceptFiles(Handle, false);
inherited;
end;
procedure TPanel.WMDropFiles(var Message: TWMDropFiles);
var
c: integer;
fn: array[0..MAX_PATH-1] of char;
begin
c := DragQueryFile(Message.Drop, $FFFFFFFF, fn, MAX_PATH);
if c <> 1 then
begin
MessageBox(Handle, 'Too many files.', 'Drag and drop error', MB_ICONERROR);
Exit;
end;
if DragQueryFile(Message.Drop, 0, fn, MAX_PATH) = 0 then Exit;
frmMain.lblFileName.Caption := fn;
end;
procedure TfrmMain.panFileDropDragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
panFileDrop.Color := $00d4d3d2;
end;
end.
The problem
Delphi's concept of Drag'n'drop is not related to COM Drag and drop at all.
Borland implemented a light-weight version for dragging and dropping within the same application.
This works great and very efficient, but does not support DnD operations between applications. COM drag and drop requires you to register a drop target with the OS and accept relevant mouse messages. At no point will a COM drag&drop ever generate an standard OnDragOver event.
I fear the documentation is quite misleading when it does not make clear this source of confusion.
You are mixing Windows message based code TPanel.WMDropFiles(var Message: TWMDropFiles) with Borland's implementation for intra-application use only: TfrmMain.panFileDropDragOver(...)
The two options exist in parallel universes.
If you want to do the COM way you need to go COM all the way.
The solution
The WMDropFiles option is still a 'light-weight' solution before you go full COM and need to implement IDropTarget and all the complexity that entails.
My answer to your question is to not invent your own drag and drop but to go on the intertubes and download: https://github.com/DelphiPraxis/The-Drag-and-Drop-Component-Suite-for-Delphi
This is the up to date version of Anders Melander's famous suite which used to be at: http://melander.dk/delphi/dragdrop/
This implements COM based drag and drop and solves all your problems in one go.
It is also a fine example of beautiful code in its own right.
Take special note of the demos. The shelldragdrop stuff should cover your use case.
Would you like to know more?
http://delphi.about.com/od/vclusing/a/dragdrop.htm
I have to write program in Delphi using VCL forms. Three figures which are square, hexagon and octagonal must move to up border, then to bottom border and so on. The problem is that my program freezes, when I'm trying to put values in condition operators to stop moving, if coordinate Y = 0. Though it works(strangely) if I put value = 180, for example.
unit Main;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
type
TMainForm = class(TForm)
Image: TImage;
BeginButton: TButton;
EndButton: TButton;
Timer1: TTimer;
Edit1: TEdit;
procedure FormActivate(Sender: TObject);
procedure BeginButtonClick(Sender: TObject);
procedure EndButtonClick(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
MainForm: TMainForm;
implementation
uses Figure;
{$R *.dfm}
Var
t:single=0.0;
L:TSquare;
S:THexagon;
C:TOctagon;
Moving:Boolean=true;
procedure TMainForm.FormActivate(Sender: TObject);
begin
Image.Canvas.Brush.Color:=clWhite;
end;
procedure TMainForm.Timer1Timer(Sender: TObject);
begin
L.Move(t);
S.Move(-0.2*t);
C.Move(0.5*t);
t:=t+0.5;
end;
procedure TMainForm.BeginButtonClick(Sender: TObject);
begin
L:=TSquare.Create(60,35,Image);
S:=THexagon.Create(180,100,Image);
C:=TOctagon.Create(300,100,Image);
Timer1.Enabled:=true;
end;
procedure TMainForm.EndButtonClick(Sender: TObject);
begin
Close;
end;
initialization
finalization
L.Free;
S.Free;
C.Free;
end.
And second Unit:
Unit Figure;
Interface
uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
Type
TFigure=Class
private x,y, b,
dx:integer;
Image:TImage;
procedure Draw;virtual;abstract;
procedure Rel(t:real);virtual;
public
constructor Create(ax,ay:integer;aImage:TImage);
procedure Move(t:single);
end;
THexagon=Class(TFigure)
private procedure Draw;override;
end;
TSquare=Class(TFigure)
private procedure Draw;override;
end;
TOctagon=Class(TFigure)
private procedure Draw;override;
end;
Implementation
Constructor TFigure.Create;
Begin
inherited Create;
x:=ax; y:=ay; Image:=aImage;
End;
Procedure TFigure.Rel;
Begin
dx:=5*round(t);
End;
Procedure TFigure.Move;
Begin
Image.Canvas.Pen.Color:=clWhite;
Draw;
Image.Canvas.Pen.Color:=clBlack;
Rel(t);
Draw;
End;
Procedure TSquare.Draw;
Begin
b:=70;
Image.Canvas.MoveTo(x+round(0.5*b),y-round(0.5*b));
Image.Canvas.LineTo(x-round(0.5*b),y-round(0.5*b));
Image.Canvas.LineTo(x-round(0.5*b),y+round(0.5*b));
Image.Canvas.LineTo(x+round(0.5*b),y+round(0.5*b));
Image.Canvas.LineTo(x+round(0.5*b),y-round(0.5*b));
End;
Procedure THexagon.Draw;
Begin
b:=70;
repeat
begin
Image.Canvas.MoveTo(x+round(0.5*b),y+dx);
Image.Canvas.LineTo(x+round(0.25*b),y+round(0.5*b)+dx);
Image.Canvas.LineTo(x-round(0.25*b),y+round(0.5*b)+dx);
Image.Canvas.LineTo(x-round(0.5*b),y+dx);
Image.Canvas.LineTo(x-round(0.25*b),y-round(0.5*b)+dx);
Image.Canvas.LineTo(x+round(0.25*b),y-round(0.5*b)+dx);
Image.Canvas.LineTo(x+round(0.5*b),y+dx);
end;
until ((y+round(0.5*b)+dx)<180);
End;
Procedure TOctagon.Draw;
var
I: Integer;
p: array[1..9] of tpoint;
u:extended;
Begin
x:=300;
y:=100;
u:=0;
for I := 1 to 8 do
begin
p[i].X:=x+round(40*cos(u));
p[i].Y:=y-round(40*sin(u));
u:=u+pi/4;
end;
repeat
begin
Image.Canvas.MoveTo(p[8].x,p[8].y-dx);
for I := 1 to 8 do
Image.Canvas.LineTo(p[i].X,p[i].y-dx);
end;
until (p[3].y>50);
End;
end.
Delphi comes with an integrated debugger. You should use it. Here's how to start investigating a case where a program seems to hang.
Start your program under control of the debugger with the "play" button.
Reproduce the situation you're trying to investigate.
When the program hangs, switch to the debugger and press the "pause" button. The debugger will interrupt the execution of your program so you can investigate the current state.
Look at the call stack. (If the call-stack window isn't already visible, you can show it by using the "debug windows" menu option in the IDE.)
The call stack will show the list of functions your program has called. At the top of the stack will be the function your program was running at the moment you paused. The function below it will be the function that called the current function, and so on until you reach the bottom of the stack, which represents the main function of your program.
The function you stop in probably won't be one you wrote. Instead, it's usually a function provided by the OS or by the Delphi run-time library. You don't want to debug those. Generally, you can assume they already work properly. You're looking for a bug in your code instead.
Use the "run until return" command to let the topmost function continue running. Repeat that until you reach one of your functions on the call stack. That's probably the culprit.
Now that you've identified the problematic function, it's time to investigate it further.
Use the "step over" debugger command to run each line of your function one by one. (There's also a "step into" command, but that will step into functions that aren't yours, and you're not interested in those now.)
Observe the current values of variables in your code. You can hover the mouse over a variable to let the debugger display its value in a tool tip, or you can use the "watches" debug window to display multiple variables at once. They'll be updated after each step in your program.
Pay attention to the variables' values. You should already have some expectation of how their values should progress over the course of your program. You probably thought about that progression while you were writing the code. Think back to that time and compare the results you observe in the debugger with your previous expectations. Do they match? If so, then keep stepping through the code. If they don't match, though, then you've found a bug. Fix it.
Another source of unexpected behavior is to reach a point in your program that you didn't expect to reach. Maybe the program called a function it shouldn't have, or maybe you've executed a loop more times you wanted to. If you can work out the reason, then fix the bug. Otherwise, you might need to back up a little ways.
Identify a point in your program earlier than where you have observed the unexpected behavior. Look for the blue dots in the left margin of the code editor. Those dots represent places where you can set a breakpoint. Click one of the dots, and you should notice the line be highlighted (probably in red).
Terminate your program, and run it again.
This time, you should see the debugger stop before the program appears to hang because execution will have reached the breakpoint first. The debugger interrupts your program there.
Step through the lines of your code as you did before, and watch for the condition that causes your program to veer from the expected path of execution. When you've identified the bug, fix it.
It freezes because your repeat-until loop will never end.
repeat
begin
Image.Canvas.MoveTo(x+round(0.5*b),y+dx);
Image.Canvas.LineTo(x+round(0.25*b),y+round(0.5*b)+dx);
Image.Canvas.LineTo(x-round(0.25*b),y+round(0.5*b)+dx);
Image.Canvas.LineTo(x-round(0.5*b),y+dx);
Image.Canvas.LineTo(x-round(0.25*b),y-round(0.5*b)+dx);
Image.Canvas.LineTo(x+round(0.25*b),y-round(0.5*b)+dx);
Image.Canvas.LineTo(x+round(0.5*b),y+dx);
end;
until ((y+round(0.5*b)+dx)<180);
Its condition is based on y, b and dx values but they never change in your loop.
To confirm where it hangs, use the Pause command in Delphi, then press F7/F8 to run it step by step.
I've searched around and the general answer seems to place
SomeEdit2.setFocus;
in SomeEdit1.OnExit event. I have tried this (Using Delphi Xe5, developing for iOS) and it causes the application to crash. The app does not throw an error, it just blanks out and crashes. I've tried placing the same code in other events but it does not work as expected. For example, when placed in SomeEdit1.OnChange event, when a user hits 'done' on the virtual keyboard - Focus is switched to the desired control, but the keyboard does not show and stops working properly.
What is the proper way to change focus inbetween controls when a user hits the 'done' button provided on the virtual keyboard?
You can not compare VCL-Control behaviour with FMX-Control behaviour, because sometimes they behave different - they should not, but they do.
In VCL you have an OnExit event and it occurs right after the focus has left the control. So this is an OnAfterExit event.
In FMX the OnExit event is fired before the focus gets away. So this is an OnBeforeExit.
procedure TControl.DoExit;
begin
if FIsFocused then
begin
try
if CanFocus and Assigned(FOnExit) then
FOnExit(Self);
FIsFocused := False;
Now, what has this to do with your current problem?
If you set the focus to another control inside the OnExit event, the current active control DoExit method gets called, which calls the OnExit event, and you have a perfect circle.
So you have several options to fix this
Bug Report
The best solution is to create a bug report and let emba fix this.
There is already a bug report 117752 with the same reason. So I posted the solution as a comment.
Patch FMX.Controls.pas
Copy FMX.Controls into your project source directory and patch the buggy code (just one line)
procedure TControl.DoExit;
begin
if FIsFocused then
begin
try
FIsFocused := False; // thats the place to be, before firering OnExit event
if CanFocus and Assigned(FOnExit) then
FOnExit(Self);
//FIsFocused := False; <-- buggy here
SetFocus to control
To set the focus in the OnExit you have to do some more work, because the message to change the focus to the next control is already queued. You must ensure that the focus change to the desired control take place after that already queued focus change message. The simplest approach is using a timer.
Here is an example FMX form with 3 edit controls and each of them has an OnExit event
unit MainForm;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Graphics, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.StdCtrls,
FMX.Edit;
type
TForm1 = class(TForm)
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
EnsureActiveControl_Timer: TTimer;
procedure EnsureActiveControl_TimerTimer(Sender: TObject);
procedure Edit1Exit(Sender: TObject);
procedure Edit2Exit(Sender: TObject);
procedure Edit3Exit(Sender: TObject);
private
// locks the NextActiveControl property to prevent changes while performing the timer event
FTimerSwitchInProgress: Boolean;
FNextActiveControl: TControl;
procedure SetNextActiveControl(const Value: TControl);
protected
property NextActiveControl: TControl read FNextActiveControl write SetNextActiveControl;
public
end;
var
Form1: TForm1;
implementation
{$R *.fmx}
procedure TForm1.Edit1Exit(Sender: TObject);
begin
NextActiveControl := Edit3;
end;
procedure TForm1.Edit2Exit(Sender: TObject);
begin
NextActiveControl := Edit1;
end;
procedure TForm1.Edit3Exit(Sender: TObject);
begin
NextActiveControl := Edit2;
end;
procedure TForm1.EnsureActiveControl_TimerTimer(Sender: TObject);
begin
EnsureActiveControl_Timer.Enabled := False;
FTimerSwitchInProgress := True;
try
if (Self.ActiveControl <> NextActiveControl) and NextActiveControl.CanFocus then
NextActiveControl.SetFocus;
finally
FTimerSwitchInProgress := False;
end;
end;
procedure TForm1.SetNextActiveControl(const Value: TControl);
begin
if FTimerSwitchInProgress
or (FNextActiveControl = Value)
or (Assigned(Value) and not Value.CanFocus)
or (Self.ActiveControl = Value)
then
Exit;
FNextActiveControl := Value;
EnsureActiveControl_Timer.Enabled := Assigned(FNextActiveControl);
end;
end.
I am running an application developed with RAD Studio XE or Delphi XE under Windows 7. After rebuilding my application from previous project files, I have been testing its functionality, but the application would only run for about a month or so and starts to fail slowly. This application is supposed to run 24/7 for all time, unless Windows OS fails. So, I ran AQTime on the application for few hours and closely watched the results as the program was running. What I noticed was this. With everything else being constant and still in numbers, under resource profiling Brush, Handle, Pen and another Pen are slowly increasing in numbers especially the second pen and Brush resources. Pen seems to be increasing in numbers by about 522 every second. Also, number of handle is going up but very slowly - maybe every 15 minutes. On a side note: some of our users have had a total
catastrophic failure, where Windows OS will die completely to a point that you have to reinstall Windows again and everything else.
AQTime result:
Class_Name Object_Name
Brush Brush:54,947
Handle Handle:44,559 --Handle is increasing slowly
Pen Pen:53,378
Pen Pen:54,915 --Pen is increasing every second by 522.
The application's main window is always going to be displayed on the screen.
UPDATE2:
pen, oldPen Bursh and oldBursh are declared within a base class. They are assigned everytime within the following procedure and the procedure is used throughout the program for drawing elements right on the TForm like circle, polygon, square, line, etc.
procedure TMakerGraphic.SaveCanvas;
begin
oldPen.Assign(myForm.Canvas.Pen);
oldBrush.Assign(myForm.Canvas.Brush);
myForm.Canvas.Pen.Assign(Pen);
myForm.Canvas.Brush.Assign(Brush);
end;
procedure TMakerGraphic.RestoreCanvas;
begin
myForm.Canvas.Pen.Assign(oldPen);
myForm.Canvas.Brush.Assign(oldBrush);
end;
The Only time these variables are released is when the elements on the TForm is deleted as shown by the following Free procedure.
destructor TMakerGraphic.Free;
begin
Pen.Free;
Brush.Free;
oldPen.Free;
oldBrush.Free;
inherited Free;
end;
So, is that mean my application is leaking memory?
Any input will be greatly appreciated. Thank you.
It seems that instances of Pen and Brush are not freed properly.
If you are using the built-in drawing procedures of TCanvas, use
Canvas.Pen.Assign(anotherPen)
to fill in a new pen.
If you are using gdiplus.dll via IGDIPlus, each drawing procedure will take a argument of IGPPen or IGPBrush. Thus, either declaring the variables to pass through as IGPPen/IGPBrush; or declaring them as TGPPen/TGPBrush, and free them afterwards.
================= temporary space for sample source code ==========
I would think the following code, as OP gives, does not incur memory/resource leak.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
currPen, prevPen: TPen;
currBrush, prevBrush: TBrush;
procedure FormPaint(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure SaveCanvas;
procedure RestoreCanvas;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
currPen := TPen.Create;
prevPen := TPen.Create;
currBrush := TBrush.Create;
prevBrush := TBrush.Create;
Self.OnPaint := Self.FormPaint;
Self.OnDestroy := Self.FormDestroy;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
SaveCanvas;
RestoreCanvas;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
prevPen.Free;
prevBrush.Free;
currPen.Free;
currBrush.free;
end;
procedure TForm1.SaveCanvas;
begin
prevPen.Assign(Self.Canvas.Pen);
prevBrush.Assign(Self.Canvas.Brush);
Self.Canvas.Pen.Assign(currPen);
Self.Canvas.Brush.Assign(currBrush);
end;
procedure TForm1.RestoreCanvas;
begin
Self.Canvas.Pen.Assign(prevPen);
Self.Canvas.Brush.Assign(prevBrush);
end;
end.