Normal behaviour for the caret in Windows 10 seems to be that as soon as a caret-capable control gets focus the caret will blink for about 5 seconds and then go solid (non-blinking). Whenever the left or right arrow keys are pressed it will move the caret and then it will start to blink again for the 5 second period, etc.
I cannot get the same behaviour on my custom control. Creation, displaying, moving and destruction of the caret seems to work fine but it will only blink for the 5 second duration after getting focus and perhaps one more time upon moving it with the arrow keys but never after that again. It stays solid (non-blinking) every time I move the caret with the arrow keys.
It will blink again if the control looses focus and regains it.
I noticed on another 3rd party control's source code that the authors used the SetCaretBlinkTime api call and I wonder if that was to get the desired effect but SetCaretBlinkTime's documenation encourages developers to only use it when actually wanting to set the blink rate similar to what the Keyboard Control Panel Applet does.
My custom control:
const
CCharWidth = 8;
CWidth = 200;
CInsideMargin = 2;
CCharsPerLine = (CWidth - (CInsideMargin * 2)) div CCharWidth;
type
TEditPane = class(TCustomControl)
private
FCaretPosX : Integer;
procedure SetCaretPosition(AXPos : Integer);
procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
protected
procedure Paint; override;
public
end;
implementation
procedure TEditPane.Paint;
begin
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := clWindow;
Canvas.FillRect(Rect(0,0,Width,Height));
end;
procedure TEditPane.SetCaretPosition(AXPos : Integer);
begin
If AXPos < CInsideMargin then
AXPos := CInsideMargin;
If AXPos > CInsideMargin + (CCharsPerLine * CCharWidth) then
AXPos := CInsideMargin + (CCharsPerLine * CCharWidth);
FCaretPosX := AXPos;
SetCaretPos(FCaretPosX,CInsideMargin);
end;
procedure TEditPane.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
inherited;
Message.Result := Message.Result or DLGC_WANTARROWS;
end;
procedure TEditPane.WMKeyDown(var Message: TWMKeyDown);
begin
inherited;
Case Message.CharCode of
VK_LEFT :
SetCaretPosition(FCaretPosX - CCharWidth);
VK_RIGHT :
SetCaretPosition(FCaretPosX + CCharWidth);
end;
end;
procedure TEditPane.WMKillFocus(var Message: TWMKillFocus);
begin
inherited;
HideCaret(Handle);
DestroyCaret;
end;
procedure TEditPane.WMLButtonDown(var Message: TWMLButtonDown);
begin
inherited;
SetFocus;
end;
procedure TEditPane.WMSetFocus(var Message: TWMSetFocus);
begin
inherited;
CreateCaret(Handle,0,1,13);
SetCaretPosition(CInsideMargin);
ShowCaret(Handle);
end;
Blinking is resumed after you show the caret. So you can
HideCaret(Handle); { assuming that show counter is 1 }
ShowCaret(Handle);
or repeat your code form WMSetFocus
CreateCaret(Handle,0,1,13);
SetCaretPosition(CInsideMargin);
ShowCaret(Handle);
Blinking also resumes after BeginPaint and EndPaint because it implicitly hides and shows caret if visible but it is side-effect and shouldn't be relied on.
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;
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.
I want my form to handle the arrow keys, and I can do it -- as long as there is no button on the form. Why is this?
Key messages are processed by the controls themselves who receives these messages, that's why when you're on a button the form is not receiving the message. So normally you would have to subclass these controls, but the VCL is kind enough to ask the parenting form what to do if the form is interested:
type
TForm1 = class(TForm)
..
private
procedure DialogKey(var Msg: TWMKey); message CM_DIALOGKEY;
..
procedure TForm1.DialogKey(var Msg: TWMKey);
begin
if not (Msg.CharCode in [VK_DOWN, VK_UP, VK_RIGHT, VK_LEFT]) then
inherited;
end;
François editing: to answer the OP original question, you need to call onKeyDown somehow so that his event code would work (feel free to edit; was too long for a comment).
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
private
{ Private declarations }
procedure DialogKey(var Msg: TWMKey); message CM_DIALOGKEY;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.DialogKey(var Msg: TWMKey);
begin
case Msg.CharCode of
VK_DOWN, VK_UP, VK_RIGHT, VK_LEFT:
if Assigned(onKeyDown) then
onKeyDown(Self, Msg.CharCode, KeyDataToShiftState(Msg.KeyData));
else
inherited
end;
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
case Key of
VK_DOWN: Top := Top + 5;
VK_UP: Top := Top - 5;
VK_LEFT: Left := Left - 5;
VK_RIGHT: Left := Left + 5;
end;
end;
Arrow keys are used to navigate between buttons on a form. This is standard Windows behaviour. Although you can disable this standard behaviour you should think twice before going against the platform standard. Arrow keys are meant for navigation.
If you want to get the full low down on how a key press finds its way through the message loop I recommend reading A Key's Odyssey. If you want to intercept the key press before it becomes a navigation key, you need to do so in IsKeyMsg or earlier. For example, Sertac's answer gives one such possibility.
Only the object that has the focus can receive a keyboard event.
To let the form have access to the arrow keys event,
declare a MsgHandler in the public part of the form.
In the form create constructor, assign the Application.OnMessage to this MsgHandler.
The code below intercepts the arrow keys only if they are coming from a TButton descendant. More controls can be added as needed.
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnMessage := Self.MsgHandler;
end;
procedure TForm1.MsgHandler(var Msg: TMsg; var Handled: Boolean);
var
ActiveControl: TWinControl;
key : word;
begin
if (Msg.message = WM_KEYDOWN) then
begin
ActiveControl := Screen.ActiveControl;
// if the active control inherits from TButton, intercept the key.
// add other controls as fit your needs
if not ActiveControl.InheritsFrom(TButton)
then Exit;
key := Msg.wParam;
Handled := true;
case Key of // intercept the wanted keys
VK_DOWN : ; // doStuff
VK_UP : ; // doStuff
VK_LEFT : ; // doStuff
VK_RIGHT : ; // doStuff
else Handled := false;
end;
end;
end;
Because they are preempted to deal with setting the focus on the next available WinControl.
(I'm pretty sure that if you put an Edit instead of a Button you see the same thing).
If you want to handle them yourself, you can provide the Application with an OnMessage event that will filter those before they are processed and handle them yourself there.
var
KBHook: HHook; {this intercepts keyboard input}
implementation
{$R *.dfm}
function KeyboardHookProc(Code: Integer; WordParam: Word; LongParam: LongInt): LongInt; stdcall;
begin
case WordParam of
vk_Space: ShowMessage ('space') ;
vk_Right:ShowMessage ('rgt') ;
vk_Left:ShowMessage ('lft') ;
vk_Up: ShowMessage ('up') ;
vk_Down: ShowMessage ('down') ;
end; {case}
end;
procedure TForm4.FormCreate(Sender: TObject);
begin
KBHook:=SetWindowsHookEx(WH_KEYBOARD,#KeyboardHookProc,HInstance,GetCurrentThreadId());
end;
This code will work even when a control is focused (buttons , listboxes), so be careful some controls may loose their keyboard events (Read David haffernans answer) .
keyboard events with Focused controls
eg: If you are having textbox in your app and want to recive text(if focused) also , then
add an applicationevent1
procedure TForm4.ApplicationEvents1Message(var Msg: tagMSG;var Handled: Boolean);
begin
if Msg.message = WM_KEYFIRST then
KBHook:=SetWindowsHookEx(WH_KEYBOARD,#KeyboardHookProc,HInstance,GetCurrentThreadId());
end;
add the following code at the bottom of the function KeyboardHookProc
UnhookWindowsHookEx(KBHook);
and remove
KBHook:=SetWindowsHookEx(WH_KEYBOARD,#KeyboardHookProc, HInstance,
GetCurrentThreadId());
from oncreate event.
I need to write an application that displays two different pictures in two instances of the application. These pictures must look as if they were put side by side on the canvas of the same window but for internal reasons it must be two different applications not a single one. Is there any way to turn off the window frame regardless of what the user's Windows settings are? I still want to retain the title bar and the close/minimize/maximize buttons.
Bonus points if the two (or multiple) windows look and react like a single one to the user.
A Delphi example would be nice but I can probably do with a hint on which flags or whatever to set using Win32 API (no dotNET please).
Since windows with title bars always have borders, your next option is to make a borderless window and then paint a title bar at the top of the window yourself. That means handling mouse messages, too. Start with wm_NCHitTest. To make a borderless window, override your form's CreateParams method and set the Style field so there's no border.
This creates a Form without side or bottom borders:
type
TForm1 = class(TForm)
private
FBorderWidth: Integer;
FTitleHeight: Integer;
procedure AppRestored(Sender: TObject);
procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT;
protected
procedure Resize; override;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TForm1 }
procedure TForm1.AppRestored(Sender: TObject);
begin
Repaint;
end;
procedure TForm1.Resize;
begin
inherited Resize;
if FBorderWidth = 0 then
begin
FBorderWidth := (Width - ClientWidth) div 2;
FTitleHeight := Height - ClientHeight - FBorderWidth;
Application.OnRestore := AppRestored;
end;
Invalidate;
end;
procedure TForm1.WMNCCalcSize(var Message: TWMNCCalcSize);
begin
inherited;
with Message.CalcSize_Params^ do
begin
Dec(rgrc[0].Left, FBorderWidth);
Inc(rgrc[0].Right, FBorderWidth);
Inc(rgrc[0].Bottom, FBorderWidth);
end;
end;
procedure TForm1.WMNCPaint(var Message: TWMNCPaint);
begin
DeleteObject(Message.RGN);
Message.RGN := CreateRectRgn(Left, Top, Left + Width, Top + FTitleHeight);
inherited;
end;