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.
Related
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.
I'm stuck in a class derived from TShape.
In the Paint method, I use the Canvas to draw a rectangle. In the Form, I have a TTrackBar that allows to change Left and Top coordinates of the TShape.
It does not matter what values I set to the Left and Top using the TTrackBar, the rectangle does not move accordingly. Instead, when I set those values via code, the rectangle appears in the correct position.
I'm coding a FireMonkey app with Delphi 10.1 Berlin on Windows 10.
unit frmShapeStudy;
interface
type
tMy_Shape = class (tShape)
protected
procedure Paint; override;
public
constructor Create (aOwner: tComponent); override;
procedure Draw;
end;
tformShapeStudy = class (tForm)
trkBarLeft: TTrackBar;
trkBarTop: TTrackBar;
procedure FormCreate (Sender: tObject);
procedure TrackBarChange (Sender: tObject);
end;
var
formShapeStudy: tformShapeStudy;
implementation
{$R *.fmx}
var
My_Shape : tMy_Shape;
lvShapeRect : tRectF ;
procedure tformShapeStudy.FormCreate (Sender: tObject);
begin
My_Shape := tMy_Shape.Create (Self);
with My_Shape do begin
Parent := Self;
TrackBarChange (Self);
end;
end;
procedure tformShapeStudy.TrackBarChange (Sender: TObject);
begin
My_Shape.Draw;
end;
constructor tMy_Shape.Create (aOwner: tComponent);
begin
inherited;
with lvShapeRect do begin
Left := Self.Left;
Top := Self.Top ;
Height := 20;
Width := 20;
end;
end;
procedure tBS_Shape.Draw;
begin
l := formShapeStudy.trkBarLeft.Value;
t := formShapeStudy.trkBarTop .Value;
{`Left & Top` are set with `l & t` or with `120 & 150`
and tested separately, by commenting the propper code lines}
lvShapeRect.Left := l; // this does no work
lvShapeRect.Top := t; // this does no work
lvShapeRect.Left := 120; // this works
lvShapeRect.Top := 150; // this works
Repaint;
end;
procedure tMy_Shape.Paint;
begin
inherited;
with Canvas do begin
Fill .Color := tAlphaColorRec.Aqua;
Stroke.Color := tAlphaColorRec.Blue;
BeginScene;
FillRect (lvShapeRect, 0, 0, Allcorners, 1, tCornerType.Bevel);
DrawRect (lvShapeRect, 0, 0, Allcorners, 1, tCornerType.Bevel);
EndScene;
end;
end;
end.
Sorry Folks! Is the old habit of using Left & Top instead of Position.X & Position.Y. I agree with the new Position way to set Left & Top, but it doesn't make sense that Embarcadero still makes available this properties, but they do nothing in terms of setting Left & Top of the control. Saying it in other words, since those old properties are still available, they should set the Left & Top properties same as Position.X & Position.Y, otherwise it leads to this kind of mistake, where you sware you are setting Left & Top, but the control does not move.
The correct way to set Left & Top is:
Position.X := aLeft;
Position.Y := aTop;
unless Embarcadero changes the behavior of Left & Top properties (wich is very unlikely).
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;
I use a timage in a form which load a background image.
The problem is when i choose another picture in run time and change it by
Img_Bk.Picture.LoadFromFile( SaveFileName );
It doesnt work (Picture did n't change ). I mean it shows previous picture and doesn't show the new image during run time. Id like to change application background image during run time in my company by users which main form is a mdi form .
I use delphi 7 .
try
Img_Bk.Picture := nil ;
if FileSize > 100 then
begin
Img_Bk.Picture.LoadFromFile( SaveFileName );
end;
Img_Bk.Stretch := True ;
except
end;
LoadFromFile is known to work. So there must be a more prosaic explanation.
The first possible explanation is that FileSize is not greater than 100 and the if condition evaluates false.
Another possible explanation is that the image in the file that you specify is not the one you are expecting.
Otherwise, your code has a swallow all exception handler. And so when the call to LoadFromFile fails and raises an exception, your code ignores that and carries on as if nothing un-toward had happened. Remove the try/except, and deal with the error that will be revealed.
The real lesson for you to learn is never to write such an exception handler again.
This program should prove to you that LoadFromFile is just fine:
program ImageDemo;
uses
Types, Math, IOUtils, SHFolder, Forms, Controls, StdCtrls, ExtCtrls, jpeg;
var
Form: TForm;
Image: TImage;
Timer: TTimer;
ImageIndex: Integer = -1;
MyPictures: string;
Images: TStringDynArray;
type
THelper = class
class procedure Timer(Sender: TObject);
end;
class procedure THelper.Timer(Sender: TObject);
begin
inc(ImageIndex);
if ImageIndex>high(Images) then
ImageIndex := 0;
if ImageIndex>high(Images) then
exit;
Image.Picture.LoadFromFile(Images[ImageIndex]);
end;
function GetMyPictures: string;
var
Str: array[0..260] of Char;
begin
if SHGetFolderPath(0, CSIDL_MYPICTURES, 0, 0, Str) = S_OK then
Result := Str;
end;
procedure BuildForm;
begin
Form.ClientWidth := 700;
Form.ClientHeight := 500;
Image := TImage.Create(Form);
Image.Parent := Form;
Image.Align := alClient;
Image.Stretch := True;
Timer := TTimer.Create(Form);
Timer.OnTimer := THelper.Timer;
Timer.Interval := 100;
end;
begin
MyPictures := GetMyPictures;
Images := TDirectory.GetFiles(MyPictures, '*.jpg', TSearchOption.soAllDirectories);
Application.MainFormOnTaskbar := True;
Application.CreateForm(TForm, Form);
BuildForm;
Application.Run;
end.
I had the same problem today. After the call of LoadFromFile() the image does not change. I have tried Refresh, Repaint, Invalidate and Update -> nothing helped. Then I found that resizing the from immediately updated the image.
Finally I found that setting property Visible to false and back to true updates the image, too.
FormMain.Image1.Visible := false;
FormMain.Image1.Picture.LoadFromFile(newImageFileName);
FormMain.Image1.Visible := true;
Perhaps not the best but it works for me.
I want to minimize a Delphi application to the systray instead of the task bar.
The necessary steps seem to be the following:
Create icon which should then be displayed in the systray.
When the user clicks the [-] to minimize the application, do the following:
Hide the form.
Add the icon (step #1) to the systray.
Hide/delete the application's entry in the task bar.
When the user double-clicks the application's icon in the systray, do the following:
Show the form.
Un-minimize the application again and bring it to the front.
If "WindowState" is "WS_Minimized" set to "WS_Normal".
Hide/delete the application's icon in the systray.
When the user terminates the application, do the following:
Hide/delete the application's icon in the systray.
That's it. Right?
How could one implement this in Delphi?
I've found the following code but I don't know why it works. It doesn't follow my steps described above ...
unit uMinimizeToTray;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ShellApi;
const WM_NOTIFYICON = WM_USER+333;
type
TMinimizeToTray = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure CMClickIcon(var msg: TMessage); message WM_NOTIFYICON;
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
MinimizeToTray: TMinimizeToTray;
implementation
{$R *.dfm}
procedure TMinimizeToTray.CMClickIcon(var msg: TMessage);
begin
if msg.lparam = WM_LBUTTONDBLCLK then Show;
end;
procedure TMinimizeToTray.FormCreate(Sender: TObject);
VAR tnid: TNotifyIconData;
HMainIcon: HICON;
begin
HMainIcon := LoadIcon(MainInstance, 'MAINICON');
Shell_NotifyIcon(NIM_DELETE, #tnid);
tnid.cbSize := sizeof(TNotifyIconData);
tnid.Wnd := handle;
tnid.uID := 123;
tnid.uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
tnid.uCallbackMessage := WM_NOTIFYICON;
tnid.hIcon := HMainIcon;
tnid.szTip := 'Tooltip';
Shell_NotifyIcon(NIM_ADD, #tnid);
end;
procedure TMinimizeToTray.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caNone;
Hide;
end;
end.
If it still works, it's probably easiest to use JVCL's TJvTrayIcon to handle it automatically.
I would recommend using CoolTrayIcon. The author has already worked out all the issues involved with tray icons. Its free with source and examples and very debugged.
http://subsimple.com/delphi.asp
Instead of Application.BringToFront; use SetforegroundWindow(Application.Handle);
In the following text I'll be referring to the step numbers mentioned in the question:
The following solution is without any additional components. It's very easy to implement.
Step #1:
Just use the application's main icon (see following code).
Step #2:
procedure TForm1.ApplicationEvents1Minimize(Sender: TObject);
begin
Shell_NotifyIcon(NIM_ADD, #TrayIconData);
Form1.Hide;
end;
Step #3:
procedure TForm1.TrayMessage(var Msg: TMessage);
begin
if Msg.lParam = WM_LBUTTONDOWN then begin
Form1.Show;
Form1.WindowState := wsNormal;
Application.BringToFront;
Shell_NotifyIcon(NIM_DELETE, #TrayIconData);
end;
end;
Step #4:
procedure TForm1.FormDestroy(Sender: TObject);
begin
Shell_NotifyIcon(NIM_DELETE, #TrayIconData);
end;
Necessary code in interface part:
uses
[...], ShellApi;
const
WM_ICONTRAY = WM_USER + 1;
type
TForm1 = class(TForm)
[...]
procedure TrayMessage(var Msg: TMessage); message WM_ICONTRAY;
end;
The only problem: The application can be minimized to the systray only once. The next time you want to minimize it, nothing will happen. Why?
Source: delphi.about.com