I am using a looping primitive code to output a test image:
procedure TForm1.Button1Click(Sender: TObject);
var
LP1, LP2: TLogPen;
hp1, hp2: THandle;
hdcv: Handle;
i: integer;
begin
LP1.lopnColor:=$FF0000;
LP1.lopnStyle:=0;
LP1.lopnWidth:=Classes.Point(1,0);
LP2.lopnColor:=$FFFFFF;
LP2.lopnStyle:=0;
LP2.lopnWidth:=Classes.Point(1,0);
hp1:=Windows.CreatePenIndirect(Windows.LOGPEN(LP1));
hp2:=Windows.CreatePenIndirect(Windows.LOGPEN(LP2));
hdcv:=Canvas.Handle;
for i:=1 to 1000 do
begin
SelectObject(hdcv, hp1);
Windows.MoveToEx(hdcv, 10+2*i, 10, nil);
Windows.LineTo(hdcv, 50+2*i, 50);
Sleep(100);
Application.ProcessMessages;
SelectObject(hdcv, hp2);
Windows.MoveToEx(hdcv, 10+2*i+1, 10, nil);
Windows.LineTo(hdcv, 50+2*i+1, 50);
Sleep(100);
Application.ProcessMessages;
end;
Windows.DeleteObject(hp1);
Windows.DeleteObject(hp2);
end;
The problem is that when the mouse is on the button (Button1), lines output is intermittent. As if drawing takes place in some kind of buffer, and after some time it is displayed on the form. I recorded a video. I am using Windows 7 and Lazarus 1.6.4. Can someone explain this graphics behavior?
During the sleep, windows repaint messages can't operate. So it is possible that the repaint only happens on the processmessages stage.
The best solution is to rewrite this asynchronously using a timer.
To test the hypothesis you could replace the sleep-application.processes with a more fine grained solution like
So instead of
sleep(100);
Application.ProcessMessages;
we replace it with
for y:=1 to 10 do
begin
sleep(10);
Application.ProcessMessages;
end;
Somewhat nicer is a solution like this (pseudocode only):
startticks:=gettickcount64; // startticks = int64
while (gettickcount64-startticks)<100 do
begin
sleep(10);
Application.ProcessMessages;
end;
which accounts better for the time spent in Application.Processmessages.
Related
I've a strange problem. I started approx. 160 processes. Now, if the mouse pointer is on the Desktop, some actions which used to take 100ms, now take 10 seconds although the total load of the system is 13-16%. Even thrid party programs like processhacker slowing down and doesn't refresh their gui. If I move the mouse pointer over some window no matter which one (could be notepad) even the taskbar can help all goes back to normal. Processhacker is refreshing his lists and the responsivness is back to 100ms.
Since Microsoft-Support won't help use - since or processes are programmed in Borland-Delphi we have no idea how to find out what's going on here.
A colleague tries to reproduce the effect with this little test program:
unit Unit1;
interface
uses
Forms,
ExtCtrls,
Classes,
Controls,
StdCtrls;
const
DEFAULT_INTERVAL = 31;
MOD_VALUE = 5;
MOD_INTERVAL = DEFAULT_INTERVAL * MOD_VALUE;
DEVIATION_BLACK = 2;
DEVIATION_RED = 10;
type
TForm1 = class(TForm)
Label1: TLabel;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
Timer: TTimer;
lastTime: TDateTime;
procedure OnTimer(Sender: TObject);
procedure SetLabel(lbl: TLabel);
end;
var
Form1: TForm1;
GCounterT: Integer;
implementation
uses
Windows,
Graphics,
SysUtils,
DateUtils;
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
Self.DoubleBuffered := True;
Timer := TTimer.Create(nil);
Timer.Interval := DEFAULT_INTERVAL;
Timer.OnTimer := OnTimer;
GCounterT := 0;
lastTime := Now();
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Timer.Free;
end;
procedure TForm1.OnTimer(Sender: TObject);
begin
Inc(GCounterT);
if (GCounterT mod MOD_VALUE) = 0 then begin
SetLabel(Label1);
GCounterT := 0;
end;
end;
procedure TForm1.SetLabel(lbl: TLabel);
var
newValue: string;
nowTime: TDateTime;
msDiff: Integer;
newColor: TColor;
begin
if IsIconic(Application.Handle) then Exit;
nowTime := Now();
msDiff := MilliSecondsBetween(nowTime, lastTime);
lastTime := nowTime;
newValue := Format('TTimer: %s dev: %d',[FormatDateTime('ss.zzz', nowTime), msDiff - MOD_INTERVAL]);
if (msDiff <= (MOD_INTERVAL + DEVIATION_BLACK))
and (msDiff >= (MOD_INTERVAL - DEVIATION_BLACK)) then
newColor := clGreen
else if (msDiff <= (MOD_INTERVAL + DEVIATION_RED))
and (msDiff >= (MOD_INTERVAL - DEVIATION_RED)) then
newColor := clBlack
else
newColor := clRed;
try
lbl.Font.Color := newColor;
lbl.Caption := newValue;
except
end;
end;
end.
The effect in not as strong as with the original processes, but it's reproduceable.
If one starts 180 of this you can see the same effect only the slowdown is not that severe.
Update Aug 04:
I've added a screenshot from a WPA-Analyze-Session. Here one can see the sequence. Starting with mouse on a Window, then Desktop, Window, Desktop and ending with mouse on Window.
You can see, that the Thread: CSwitch count is going nearly half if the mouse is on the Desktop. What you also could see is that the system load is between 10-17% the whole time.
After we managed to add debug-symbols to some of our processes, we found the issue in the Delphi-VCL/Forms.pas.
In a new trace, with debug-symbols, we saw that the Application.DoMouseIdle method spends a lot of time finding VCLWindows, get Parents of these and so on.
The source of the slowdown is the "FindDragTarget" method. Our processes need no drag'n'drop functionality and they need no hint showing somewhere. So we cut this function call out of the code, which was not easy.
Now everything is running fast undependend from the mouse position.
I am minimizing a form to system tray (display a tray icon) while keeping its taskbar button when it is not minimized. This implies removing the taskbar button when the form is minimized and restoring it otherwise.
The simplest way to achieve this is to hide/show the form, a minimized window does not show anyway.
type
TForm1 = class(TForm)
TrayIcon1: TTrayIcon;
procedure TrayIcon1DblClick(Sender: TObject);
protected
procedure WMSize(var Message: TWMSize); message WM_SIZE;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.WMSize(var Message: TWMSize);
begin
inherited;
case Message.SizeType of
SIZE_MINIMIZED:
if not TrayIcon1.Visible then begin
TrayIcon1.Visible := True;
Hide;
end;
SIZE_RESTORED, SIZE_MAXIMIZED:
if TrayIcon1.Visible then begin
Show;
Application.BringToFront;
TrayIcon1.Visible := False;
end;
end;
end;
procedure TForm1.TrayIcon1DblClick(Sender: TObject);
begin
Show;
WindowState := wsNormal;
end;
The above application introduces a visual glitch when "Animate windows when minimizing and maximizing" setting of the OS is on (accessible through 'SystemPropertiesPerformance.exe'). The minimize window animation is skipped. It appears that the animation actually takes place after the window is minimized. In the code, the window is already hidden by then.
One solution could be to have a notification when the window manager is done with the animation and hiding the form after that. I can't find any. When, for instance, you use the taskbar button minimizing the window, the last message sent is the WM_SYSCOMMAND, which doesn't lead to any progress if I move the code (not to mention that a window can be minimized through a ShowWindow and others).
Another solution might involve to know how long the animation takes place. SystemParametersInfo doesn't have it. Similar question here tries to deal with the animation displayed when a window is first shown, although that animation seems to be related with DWM and minimize/maximize animation precedes DWM. No conclusive solution there either. Like in that question, a 250ms delay seems to work fine. But I'm not sure this is a universally sound delay. I'm not even sure a discrete delay would be definitive, perhaps a stutter would cause it to extent (not that it would matter much, but anyway...).
I also tried to actually remove the taskbar button, without hiding the form. But it's more clumsy and it doesn't change the output: the animation is skipped.
Comment about DrawAnimatedRects (which draws no animation when Aero is on) convinced me to go slightly undocumented until I have a better alternative. Methods using DrawAnimatedRects have to determine where to minimize, that's where they use undocumented system tray window class name.
The below code goes undocumented when removing the taskbar button of the form, in particular with the use of the GWLP_HWNDPARENT index of SetWindowLongPtr. In any case, removing the taskbar button is not clumsy as in transforming the window to a tool window and the animation goes smooth.
The code falls back to a timer which hides the form in case removing the taskbar button fails.
type
TForm1 = class(TForm)
TrayIcon1: TTrayIcon;
Timer1: TTimer;
procedure TrayIcon1DblClick(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormCreate(Sender: TObject);
protected
procedure WMSize(var Message: TWMSize); message WM_SIZE;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function ShowTaskbarButton(Wnd: HWND; Show: Boolean = True;
OwnerWnd: HWND = 0): Boolean;
var
ExStyle, HWndParent: LONG_PTR;
IsToolWindow: Boolean;
begin
HwndParent := GetWindowLongPtr(Wnd, GWLP_HWNDPARENT);
ExStyle := GetWindowLongPtr(Wnd, GWL_EXSTYLE);
Result := Show = (HWndParent = 0) and (ExStyle and WS_EX_APPWINDOW <> 0);
if not Result then begin
IsToolWindow := ExStyle and WS_EX_TOOLWINDOW <> 0;
if IsToolWindow then begin
ShowWindow(Wnd, SW_HIDE);
ShowWindowAsync(Wnd, SW_SHOW);
end;
SetLastError(0);
if Show then
SetWindowLongPtr(Wnd, GWL_EXSTYLE, ExStyle or WS_EX_APPWINDOW)
else
SetWindowLongPtr(Wnd, GWL_EXSTYLE, ExStyle and not WS_EX_APPWINDOW);
if not IsToolWindow and (GetLastError = 0) then
SetWindowLongPtr(Wnd, GWLP_HWNDPARENT, OwnerWnd);
Result := GetLastError = 0;
end;
end;
procedure TForm1.WMSize(var Message: TWMSize);
begin
inherited;
case Message.SizeType of
SIZE_MINIMIZED:
if not TrayIcon1.Visible then begin
if not ShowTaskbarButton(Handle, False, Application.Handle) then
Timer1.Enabled := True; // fall back
TrayIcon1.Visible := True
end;
SIZE_RESTORED, SIZE_MAXIMIZED:
if TrayIcon1.Visible then begin
ShowTaskbarButton(Handle);
Application.BringToFront;
TrayIcon1.Visible := False;
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Timer1.Interval := 250;
Timer1.Enabled := False;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Hide;
Timer1.Enabled := False;
end;
procedure TForm1.TrayIcon1DblClick(Sender: TObject);
begin
ShowTaskbarButton(Handle);
if not Showing then // used timer to hide
Show;
WindowState := wsNormal;
end;
Ok so first of all i'm just messing around in delphi, and still really new to it, but i noticed that whenever i try to make some kind of game , where W,A,S, and D are the buttons which moves an object (TImage) , it starts flashing randomly, i noticed that it happens if the speed is fast, or when it's moving and there is another image (background) behind it...
Most of my "moving" code looks like this:
if key = 's' then begin
for I := 1 to 5 do
sleep(1);
x:=x-2;
Image1.Top := x;
end;
Maybe that causes it, but still it's really annoying. I would be really pleased if you could help with this.
Something like this is better handled using TPaintBox instead.
Have the keystrokes set variables as needed and then call TPaintBox.Invalidate() to trigger a repaint when the OS is ready for it.
The TPaintBox.OnPaint event handler can then draw a TGraphic at the appropriate coordinates specified by the current variable values as needed.
var
X: Integer = 0;
Y: Integer = 0;
procedure TMyForm.KeyPress(Sender: TObject; var Key: Char);
begin
case Key of
'W': begin
Dec(Y, 2);
PaintBox.Invalidate;
end;
'A': begin
Dec(X, 2);
PaintBox.Invalidate;
end;
'S': begin
Inc(Y, 2);
PaintBox.Invalidate;
end;
'D': begin
Inc(X, 2);
PaintBox.Invalidate;
end;
end;
end;
procedure TMyForm.PaintBoxPaint(Sender: TObject);
begin
PaintBox.Canvas.Draw(X, Y, SomeGraphic);
end;
I am trying out following code. However, if I click on form's close button while this code is running, nothing happens. How can I correct this? I need to close the form even when this loop is executing.
procedure TForm1.Button1Click(Sender: TObject);
var
i: Integer;
begin
for i := 0 to 9999999 do
begin
Memo1.Lines.Add('hi');
Application.ProcessMessages;
end;
end;
Have a look at what's going on inside Application.ProcessMessages.
When you close the main form, windows sends a WM_QUIT message to the program. The relevant part of TApplication.ProcessMessages looks like this:
if Msg.Message <> WM_QUIT then
begin
//skipped
end
else
begin
{$IF DEFINED(CLR)}
if Assigned(FOnShutDown) then FOnShutDown(self);
DoneApplication;
{$IFEND}
FTerminate := True;
end;
I assume this is not a CLR program, so the only thing that happens at this point is setting FTerminate := True on Application. This is reflected in the Application.Terminated property.
When the application shuts down, one of the things it does in order to shut down safely is wait for all threads to finish. This code happens to be running in the main thread, but the principle would be the same in any thread: If you're doing a long-running task that might have to finish early, you have to explicitly check for early termination.
Knowing this, it's easy to figure out how to fix your code:
procedure TForm1.Button1Click(Sender: TObject);
var
i: Integer;
begin
for i := 0 to 9999999 do
begin
Memo1.Lines.Add('hi');
Application.ProcessMessages;
if Application.Terminated then
Break;
end;
end;
Also, beware of using Application.ProcessMessages in the first place, as it will process all messages for the application. For a simple idea of what might go wrong, try adding IntToStr(i) instead of 'hi' to Memo1.Lines, knock a couple of orders of magnitude off the counter, and then click the button two or three times in rapid succession and watch the output...
Check for Apllication Terminated:
for i := 0 to 9999999 do
begin
Memo1.Lines.Add('hi');
Application.ProcessMessages;
if Application.Terminated then Exit;
end;
You need to run any tight loop in a thread. This will solve the problem.
BUT if you want to keep the code as it is, Application.ProcessMessages will make your loop terribly slow. So you need to run Application.ProcessMessages not so often:
Counter:= 0;
for i := 0 to 9999999 do
begin
DoSomeStuff;
{ Prevent freeze }
inc(Counter);
if counter > 10000 then
begin
Counter:= 0;
Application.ProcessMessages;
if Application.Terminated then Exit;
end;
end;
I'm changing the parent of a frame a runtime to move the frame from one form to another. That works fine but after that my components do not receive mouse events any longer. For example, CM_MOUSEENTER and CM_MOUSELEAVE is not fired.
Frame.Parent := SecondDisplayForm;
Frame.Align := alClient;
SecondDisplayForm.Show;
I don't understand this effect and I don't really know what information to provide, so if you have hints please help me out here.
It works in D7 as NGLN reported, but in BDS2006 it's reproducible. I found that it's important to change the parent after the cm_mouseenter, and before cm_mouseleave, otherways ther's no problem. The problem is in the controls.pas I think, maybe it's a bug. Playing around a little bit I found out that if you Perform a wm_mouseleave message before changing the parent everything is fine again.
In my sample code i change the parent in an onclick event.
TFrame3 = class(TFrame)
procedure FrameClick(Sender: TObject);
private
procedure CMMouseEnter( var msg: TMessage ); message CM_MOUSEENTER;
procedure CMMouseLeave( var msg: TMessage ); message CM_MOUSELEAVE;
public
end;
implementation
procedure TFrame3.CMMouseEnter(var msg: TMessage);
begin
inherited;
Color := clRed;
end;
procedure TFrame3.CMMouseLeave(var msg: TMessage);
begin
inherited;
Color := clBlue;
end;
procedure TFrame3.FrameClick(Sender: TObject);
begin
if parent = Form1 then
begin
Perform( WM_MOUSELEAVE, 0, 0 );
parent := Form2;
align := alClient;
Form1.Hide;
Form2.Show;
end else
begin
Perform( WM_MOUSELEAVE, 0, 0 );
parent := Form1;
align := alClient;
Form2.Hide;
Form1.Show;
end;
end;
I think the problem is related to the FMouseControl in Controls.pas, but haven't investigated it properly.