Delphi - Rate of clicking TImage slow compared with TButton - delphi

I have a form with both a TImage and a TButton control. I noticed the rate of responding to the OnClick event seemed a bit slow for the TImage (rapid clicking!) so I measured it. For 100+ clicks (and clicking as fast as I could, keeping the rate as consistent as I could for each control) I got the metrics:
TButton: Average ~105-116ms
TImage: Average ~220-235ms
I repeated this a few times with similar results. Why is the TImage processing clicks about half the rate of the TButton? Could it be slower to process the Windows message queue from WM_LBUTTON_DOWN to the OnClick event? Maybe it is swallowing Clicks if they are within N ms of the previous click?
There's doesn't seem to be anything in the properties of the TImage that affects this.
Note: Using Delphi 7 and the standard VCL controls here, if that is relevant.
EDIT: Here is some example code demonstrating how I timed things:
// Define variables (in class definition)
m_dwBtnClicks, m_dwImgClicks: DWORD;
m_dwLastBtnClickTicks, m_dwLastImgClickTicks: DWORD;
m_fTotalBtnClicksTicks, m_fTotalImgClicksTicks: Single;
// Initialise variables (in form's OnCreate event)
m_dwBtnClicks := 0;
m_dwImgClicks := 0;
m_dwLastBtnClickTicks := 0;
m_dwLastImgClickTicks := 0;
m_fTotalImgClicksTicks := 0.0;
m_fTotalImgClicksTicks := 0.0;
// OnClick events
procedure TfrmQwerty.btnClick(Sender: TObject);
var
dwTime: DWORD;
begin
// TButton click!
Inc(m_dwBtnClicks);
dwTime := GetTickCount();
if (m_dwLastBtnClickTicks > 0) then
m_fTotalBtnClicksTicks := (m_fTotalBtnClicksTicks + (dwTime - m_dwLastBtnClickTicks));
m_dwLastBtnClickTicks := dwTime;
end;
procedure TfrmQwerty.imgClick(Sender: TObject);
var
dwTime: DWORD;
begin
// TImage click!
Inc(m_dwImgClicks);
dwTime := GetTickCount();
if (m_dwLastImgClickTicks > 0) then
m_fTotalImgClicksTicks := (m_fTotalImgClicksTicks + (dwTime - m_dwLastImgClickTicks));
m_dwLastImgClickTicks := dwTime;
end;
// Some TTimer::OnTimer event to update the results on-screen
procedure TfrmQwerty.OnTextEntryTimer(Sender: TObject);
var
fTime: Single;
begin
// Stop the timer
TextEntryTimer.Enabled := False;
if (m_dwBtnClicks > 1) then
begin
fTime := m_fTotalBtnClicksTicks / m_dwBtnClicks;
lblButtonClicks.Caption := Format('BtnClicks = %d [Avg = %.3fms]', [
m_dwBtnClicks, fTime]);
end;
if (m_dwImgClicks > 1) then
begin
fTime := m_fTotalImgClicksTicks / m_dwImgClicks;
lblImageClicks.Caption := Format('ImgClicks = %d [Avg = %.3fms]', [
m_dwImgClicks, fTime]);
end;
// Restart the timer
TextEntryTimer.Enabled := True;
end;

The VCL source is your friend here. As noted, this is caused by double click messages being sent by Windows when clicking fast enough to generate them.
Let's look at what happens when clicking fast enough to trigger a double click:
Step 1 - Left mouse button goes down :
procedure TControl.WMLButtonDown(var Message: TWMLButtonDown);
begin
SendCancelMode(Self);
inherited;
if csCaptureMouse in ControlStyle then
MouseCapture := True;
if csClickEvents in ControlStyle then // !! Note here
Include(FControlState, csClicked); // Storing that we've been clicked
DoMouseDown(Message, mbLeft, []);
end;
Step 2 - Left mouse button goes up.
procedure TControl.WMLButtonUp(var Message: TWMLButtonUp);
begin
inherited;
if csCaptureMouse in ControlStyle then MouseCapture := False;
if csClicked in ControlState then // !! Note here
begin // Firing CLICK event primed
Exclude(FControlState, csClicked); // from the method above
if ClientRect.Contains(SmallPointToPoint(Message.Pos)) then
Click;
end;
DoMouseUp(Message, mbLeft);
end;
Step 3 - Left mouse button goes down again.
This time, it's a double click! Note that this is handling an entirely different message - a double click message from the OS, not a mouse down message. The handler here still fires the MouseDown event, but does not prime the control to fire a click event when the mouse button comes back up.
procedure TControl.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
SendCancelMode(Self);
inherited;
if csCaptureMouse in ControlStyle then MouseCapture := True;
if csClickEvents in ControlStyle then DblClick;
DoMouseDown(Message, mbLeft, [ssDouble]);
end;
Since a Button is a special TWinControl it receives the special BN_CLICKED message that is generated any time the button is clicked, regardless of whether it might be a double click or not. Being a simple control it does a simple job and you therefore see twice as many click events from a button when clicking quickly (faster than the double-click rate).
procedure TCustomButton.CNCommand(var Message: TWMCommand);
begin
if Message.NotifyCode = BN_CLICKED then Click;
end;
You can also note that, since a TButton will receive these special messages it is created without the csClickEvents option in its ControlStyle, so although it is also a TControl, the handling in the above steps used for the TImage (and other) controls does not apply (ie: priming for the Click in the WMLButtonDown handler).
As you have discovered, the OnMouseDown or OnMouseUp events will allow you to capture all such events in your TImage control, regardless of whether they should be treated as clicks or double clicks.
Alternatively, if you don't care about your TImage processing double clicks you can set the control style as :
Image1.ControlStyle := Image1.ControlStyle - [csDoubleClicks];
Here, in the TControl.WndProc :
if not (csDoubleClicks in ControlStyle) then
case Message.Msg of
WM_LBUTTONDBLCLK, WM_RBUTTONDBLCLK, WM_MBUTTONDBLCLK:
Dec(Message.Msg, WM_LBUTTONDBLCLK - WM_LBUTTONDOWN);
end;
You can see the double click events are transformed to simple mouse down events.

Related

How to make TImage and TLabel receive WM_RBUTTONDOWN messages?

In a Delphi 11 32-bit VCL Application in Windows 10, at run-time, I right-click a control while holding down the SHIFT and CTRL modifier keys, to copy the name of the clicked control to the clipboard:
procedure TformMain.ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean);
begin
case Msg.message of
Winapi.Messages.WM_RBUTTONDOWN:
begin
// Detect the name of the clicked control:
var ThisControl: Vcl.Controls.TWinControl;
ThisControl := Vcl.Controls.FindControl(Msg.hwnd);
if Assigned(ThisControl) then
begin
var keys: TKeyboardState;
GetKeyboardState(keys);
// when right-clicking a control, hold down the SHIFT and CTRL key to escape the possible default click behavior of the control:
if (keys[VK_SHIFT] and $80 <> 0) and (keys[VK_CONTROL] and $80 <> 0) then
begin
Handled := True;
//CodeSite.Send('TformMain.ApplicationEvents1Message: ThisControl.Name', ThisControl.Name);
Vcl.Clipbrd.Clipboard.AsText := ThisControl.Name;
end;
end;
end;
end;
end;
This works with ALMOST all controls, EXCEPT with Timage and TLabel (and possibly a few other control types). How can I make this work with Timage and TLabel too?
TImage and TLabel are derived from TGraphicControl, not TWinControl. They do not have an HWND of their own, which is why Vcl.Controls.FindControl() does not work for them. You are receiving WM_RBUTTONDOWN messages belonging to their Parent's HWND instead. Internally, when the VCL routes the message, it will account for graphical child controls. But your code is not.
Try Vcl.Controls.FindDragTarget() instead. It takes screen coordinates as input (which you can get by translating the client coordinates in WM_RBUTTONDOWN's lParam using Winapi.ClientToScreen() or Winapi.MapWindowPoints()), and then returns the TControl at those coordinates, so it works with both windowed and graphical controls.
That being said, you don't need to use Winapi.GetKeyboardState() in this situation, as WM_RBUTTONDOWN's wParam tells you whether SHIFT and CTRL keys were held down at the time the message was generated (remember, you are dealing with queued messages, so there is a delay between the time the message is generated and the time you receive it).
procedure TformMain.ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean);
const
WantedFlags = MK_SHIFT or MK_CONTROL;
begin
if Msg.message = WM_RBUTTONDOWN then
begin
// Detect the name of the clicked control:
var Pt: TPoint := SmallPointToPoint(TSmallPoint(Msg.LParam));
Windows.ClientToScreen(Msg.hwnd, Pt);
var ThisControl: TControl := FindDragTarget(Pt, True);
if Assigned(ThisControl) then
begin
// when right-clicking a control, hold down the SHIFT and CTRL key to escape the possible default click behavior of the control:
if (Msg.wParam and WantedFlags) = WantedFlags then
begin
Handled := True;
//CodeSite.Send('TformMain.ApplicationEvents1Message: ThisControl.Name', ThisControl.Name);
Clipboard.AsText := ThisControl.Name;
end;
end;
end;
end;

Delphi Firemonkey Frames - How to get the event OnEnter and OnExit of the usage of a frame

Using Delphi Tokyo and FireMonkey:
I have a lot of different frames on a form and would like to set some form-level variables as the focus on the form changes in and out of the different frames.
Ex. I have a Insert button on the form and want to enable it if the frame the user is in allows inserts and then again disable it upon leaving the frame's focus.
There are OnEnter and OnExit events on the frame, but they never execute.
Obviously there are edits etc. on the frames.
type
TForm1 = class(TForm)
Label1: TLabel;
procedure FormFocusChanged(Sender: TObject);
private
FFocusedFrame: TFrame;
public
{ Public declarations }
end;
...
procedure TForm1.FormFocusChanged(Sender: TObject);
var
LParent: TFmxObject;
begin
if Focused <> nil then
begin
LParent := Focused.GetObject.Parent;
while (LParent <> nil) and not (LParent is TFrame) do
LParent := LParent.Parent;
if (LParent <> nil) and (FFocusedFrame <> LParent) then
begin
FFocusedFrame := TFrame(LParent);
Label1.Text := FFocusedFrame.Name;
end;
end;
end;
end.
No need to hook up OnEnter and OnExit for every control
The frames can not receive focus, and therefore they do not fire OnEnter() or OnExit() events.
After you have placed a frame on the form, you can create two common event handlers for all edit controls (or other input controls on the frame)
procedure TForm14.Frame112EditExit(Sender: TObject);
begin
Button1.Enabled := False;
end;
procedure TForm14.Frame112EditEnter(Sender: TObject);
begin
Button1.Enabled := True;
end;
and link the OnEnter() and OnExit() events of all those edit controls to these two event handlers.
I was unsure whether the events are fired in correct order when moving from one edit control to anotherone, but a short test (on Windows) shows that OnExit() of the control we leave is fired before OnEnter() of the control we enter, as expected.

Slow eventhandler in TPageControl.OnChange causes weird behaviour

When I add slow code to the OnChange event of TPageControl I run into problems.
If the code is fast and doesn't take a lot of time, things are fine.
However if the code takes a long time to return +/- 0.5 to 1 second, the PageControl starts to act weird.
If the user changes a page sometimes it doesn't do anything on the first click, and a second click on the page is required to actually make the change happen.
I've kind of sort of fixed this with code like this.
(I've simplified it a bit, just to show the idea)
type TDelayProc = procedure(Sender: TObject) of object;
TForm = class(TForm)
...
private
FDelayedSender: TObject;
FDelayedEvent: TDelayProc;
procedure SetDelayedEvent(Value: TDelayProc);
property FDelayedSender: TObject read FDelayedSender write FDelayedSender;
property FDelayedEvent: TDelayProc read FDelayedEvent write SetDelayedEvent;
...
procedure TForm1.SetDelayedEvent(Value: TDelayProc);
begin
Timer1.Active:= false;
FDelayedEvent:= Value;
if Assigned(Value) then Timer1.Active:= true
else DelayedSender:= nil;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Timer1.Active:= false;
if Assigned(DelayedEvent) then DelayedEvent(DelayedSender);
end;
procedure TForm1.PageControl1Change(Sender: TObject);
begin
if PageControl1.ActivePage = TSPage1 then begin
DelayedSender:= Button1;
DelayedEvent:= Button1Click;
end; {if}
end;
As you can see this is a horrible hack.
The code I'm calling is in QuickReport to prepare a report and MySQL query and such, so I don't have much control over that.
I'm think there's some Win32 messaging that I'm messing up by not returning from TPageControl.OnChange fast enough, the delay is definitely shorter than 3 seconds though.
I've tried ProcessMessages, but that just made things worse and I don't want to use a separate thread for this.
How do I fix this so I can use the OnChange event handler like normal
I'm unclear about why you're using the TTimer stuff. If it were me, I think I'd just PostMessage a custom message to my form from the OnChange event, so the OnChange handler would return immediately. That would allow the PageControl message flow to behave normally. Then in the Message handler for that custom message I would (1) show/start a progress bar form running on a 2nd thread, (2) start the activity which is taking so much time, and (3) when the time consuming activity finishes, shut down the progress bar.
Here's some code for a threaded progress bar, that I modified from something Peter Below posted years ago. It's NOT pretty, but users don't care about that as much as they care about "nothing happening" on the screen.
unit AniMg;
{ Unit for displaying animated progress bar during a lengthy process.
* Painting of progress is done in a secondary thread, so it updates even during processing
which doesn't process Windows messages (and therefore doesn't update visible windows).
* Does NOT call Application.ProcessMessages...so it doesn't alter the order in which the
application processed messages.
USAGE:
//Delays display of the progress form. When this property <> 0, caller must pepper
//his code with .UpdateVisible calls, or the form will never be displayed.
AniMgr.DelayBeforeVisible := 3000;
//If DelayBeforeVisible time has elapsed, displays the progress form & starts thread.
AniMgr.UpdateVisible;
//Displays the progress form & starts painting it in a secondary thread.
//(If DelayBeforeVisible <> 0, sets the form's caption or caption-to-be.)
AniMgr.Push('Some caption');
//To change captions without closing/opening the progress bar form...
AniMgr.Push('Another caption');
//Close the form
AniMgr.PopAll;
NOTES:
* Do NOT call DisableTaskWindows in this unit!! It's tempting to do that when the progress
form is shown, to make it function modally. However, do so at your own risk! Having
DisableTaskWindows in effect resulted in an AV when we were called from certain routines
or component's code.
AUTHOR:
* Mark Wilsdorf, Flagship Technologies, Inc., www.goflagship.com.
* Thanks to Peter Below for his original code for painting the progress bar, and his many
years of providing stellar examples and explanations to the Delphi community.
DEVELOPMENT:
* Originally put FAniform.Show/Update on a TTimer delay, so the progress form wouldn't
display just for a brief instant during quick processes. However, we had to get rid of
Application.ProcessMessages calls (which caused problems in caller), so the TTimer wouldn't
fire. Can't make the 2ndary thread do the Show/Update job either, for the same reason:
Synchronize() won't work because the main thread is occupied in other code, and without
Application.ProcessMessages calls the Synchronize(Show/Update code) doesn't get called
until the lengthy main thread code processing finishes. The only solution appears to be:
have the 2ndary thread be fully responsible for creating and showing/updating the entire
progress window, entirely via Windows API calls.
}
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, RzLabel, ExtCtrls, RzPanel;
{$I DEFINES.PAS}
type
T_AniForm = class(TForm)
RzPanel2: TRzPanel;
RzLabel1: TRzLabel;
RzPanel1: TRzPanel;
public
r : TRect;
constructor Create(AOwner: TComponent); override;
end;
//Do NOT call DisableTaskWindows in this unit!!
//We may be called from rtnes or components which attempt to update the UI, resulting
//in an AV in certain circumstances. This was the result when used with the popular
//Developer's Express component, ExpressQuantumGrid.
TAniThread = class(TThread)
private
FWnd: HWND;
FPaintRect: TRect;
FbkColor, FfgColor: TColor;
FInterval: integer;
protected
procedure Execute; override;
public
constructor Create(paintsurface : TWinControl; {Control to paint on }
paintrect : TRect; { area for animation bar }
bkColor, barcolor : TColor; { colors to use }
interval : integer); { wait in msecs between paints}
end;
TAniMgr = class(TObject)
private
FStartTime: DWord; //=Cardinal. Same as GetTickCount
FDelayBeforeVisible: cardinal;
FRefCount: integer;
FAniThread : TAniThread;
FAniForm: T_AniForm;
// procedure SetDelayBeforeVisible(Value: cardinal);
procedure StopIt;
public
procedure Push(const NewCaption: string);
procedure UpdateVisible;
//procedure Pop; Don't need a Pop menthod until we Push/Pop captions...
procedure PopAll;
//
//Delay before form shows. Takes effect w/r/t to first Push() call.
property DelayBeforeVisible: cardinal read FDelayBeforeVisible write FDelayBeforeVisible;
end;
function AniMgr: TAniMgr; //function access
implementation
{$R *.dfm}
var
_AniMgr : TAniMgr = nil; //Created privately in Initialization section
//Do NOT DisableTaskWindows in this unit!!
//We're called from some rtnes which attempt to update the UI, resulting in an AV.
//DisabledWindows: pointer = nil;
function AniMgr: TAniMgr;
begin
if not Assigned(_AniMgr) then
_AniMgr := TAniMgr.Create;
Result := _AniMgr;
end;
//---------------------------------------------------------------------------------------------
// TAniMgr
//---------------------------------------------------------------------------------------------
procedure TAniMgr.UpdateVisible;
{ Checks our form's visibility & calls form.Update if appropriate.
* This rtne implements DelayBeforeVisible handling. }
begin
//Thd may be terminating...
if Assigned( FAniThread ) and FAniThread.Terminated then
exit;
if Assigned(FAniForm) and
( (DelayBeforeVisible = 0) or (GetTickCount - FStartTime > DelayBeforeVisible) ) then begin
if not Assigned(FAniThread) then
with FAniForm do begin
Show;
//Form.Update processes our paint msgs to paint the form. Do NOT call
//Application.ProcessMessages here!! It may disrupt caller's intended message flow.
Update;
//Start painting progress bar on the form
FAniThread := TAniThread.Create(RzPanel1, r, FAniForm.color, clActiveCaption, 100);
end
else
FAniForm.Update;
end;
end;
procedure TAniMgr.Push(const NewCaption: string);
{ We don't really Push a stack of captions (though we could)...for now that's not
important; we just manage the form and RefCount. }
begin
//Thd may be terminating...
if Assigned( FAniThread ) and FAniThread.Terminated then
exit;
FRefCount := FRefCount + 1;
if FAniForm = nil then begin
FAniForm := T_AniForm.Create(nil);
//If FAniForm was nil this is the first Push() of a series, so get
//a starting tick count for DelayBeforeShowing management
FStartTime := GetTickCount;
end;
FAniForm.RzLabel1.Caption := NewCaption;
UpdateVisible;
end;
procedure TAniMgr.StopIt;
begin
if Assigned( FAniThread ) then begin
if not FAniThread.Terminated then begin
FAniThread.Terminate;
FAniThread.WaitFor;
end;
end;
FreeAndNil(FAniThread);
FreeAndNil(FAniForm);
end;
//procedure TAniMgr.Pop;
//{ We don't really Pop a stack of captions...for now that's not important; we just
// decrement the RefCount. }
//begin
// if FRefCount > 0 then
// FRefCount := FRefCount - 1;
// if (FRefCount = 0) then
// StopIt;
//end;
procedure TAniMgr.PopAll;
begin
if FRefCount > 0 then try
StopIt;
finally
FRefCount := 0;
end;
end;
//---------------------------------------------------------------------------------------------
// T_AniForm
//---------------------------------------------------------------------------------------------
constructor T_AniForm.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
r := RzPanel1.ClientRect;
InflateRect(r, - RzPanel1.BevelWidth, - RzPanel1.BevelWidth);
end;
//---------------------------------------------------------------------------------------------
// TAniThread
//---------------------------------------------------------------------------------------------
constructor TAniThread.Create(paintsurface : TWinControl;
paintrect : TRect; bkColor, barcolor : TColor; interval : integer); //BeforePaint: integer);
begin
inherited Create(True); //Suspended
FWnd := paintsurface.Handle;
FPaintRect := paintrect;
FbkColor := bkColor;
FfgColor := barColor;
FInterval := interval;
FreeOnterminate := False; //So we can use WaitFor & know it's dead.
Resume;
end;
procedure TAniThread.Execute;
var
image : TBitmap;
DC : HDC;
left, right : integer;
increment : integer;
imagerect : TRect;
state : (incRight, incLeft, decLeft, decRight);
begin
Image := TBitmap.Create;
try
with Image do begin
Width := FPaintRect.Right - FPaintRect.Left;
Height := FPaintRect.Bottom - FPaintRect.Top;
imagerect := Rect(0, 0, Width, Height);
end; { with }
left := 0;
right := 0;
increment := imagerect.right div 50;
//WAS... increment := imagerect.right div 50;
state := Low(State);
while not Terminated do begin
with Image.Canvas do begin
Brush.Color := FbkColor;
FillRect(imagerect);
case state of
incRight: begin
Inc(right, increment);
if right > imagerect.right then
begin
right := imagerect.right;
Inc(state);
end; { if }
end; { case incRight }
incLeft: begin
Inc(left, increment);
if left >= right then
begin
left := right;
Inc(state);
end; { if }
end; { case incLeft }
decLeft: begin
Dec(left, increment);
if left <= 0 then
begin
left := 0;
Inc(state);
end; { if }
end; { case decLeft }
decRight: begin
Dec(right, increment);
if right <= 0 then
begin
right := 0;
state := incRight;
end; { if }
end; { case decLeft }
end; { case }
Brush.Color := FfgColor;
FillRect(Rect(left, imagerect.top, right, imagerect.bottom));
end; { with }
DC := GetDC(FWnd);
if DC <> 0 then try
BitBlt(DC,
FPaintRect.Left,
FPaintRect.Top,
imagerect.right,
imagerect.bottom,
Image.Canvas.handle,
0, 0,
SRCCOPY);
finally
ReleaseDC(FWnd, DC);
end;
Sleep(FInterval);
end; { while not Terminated}
finally
Image.Free;
end;
InvalidateRect(FWnd, nil, True);
end;
initialization
finalization
if Assigned(_AniMgr) then begin
_AniMgr.PopAll;
_AniMgr.Free;
end;
end.
The only explanation I have is that your long running handler is pumping the message queue. So long as you don't pump the queue you can take as long as you like handling an event. It might look messy since you are neglecting the queue but it will work normally.
I wish there was a BeforeChange event
that gave me the new page as a
parameter [...]
There almost is. Use the OnChanging event and the IndexOfTabAt function:
// Warning: Don't use, see below!
procedure TForm1.PageControl1Changing(Sender: TObject;
var AllowChange: Boolean);
var
pnt: TPoint;
NewTabIndex: integer;
begin
if not GetCursorPos(pnt) then Exit;
pnt := PageControl1.ScreenToClient(pnt);
NewTabIndex := PageControl1.IndexOfTabAt(pnt.X, pnt.Y);
if NewTabIndex <> -1 then
ShowMessageFmt('Next up: tab with index %d.', [NewTabIndex]);
end;
But: This only works if the user clicks a tab. It does not work if the user navigates the tab control using the keyboard. Therefore, this answer is useless (other than for educational purposes).

Close Delphi dialog after [x] seconds

Is it possible to get Delphi to close a ShowMessage or MessageDlg Dialog after a certain length of time?
I want to show a message to the user when the application is shut down, but do not want to stop the application from shutting down for more than 10 seconds or so.
Can I get the default dialog to close after a defined time, or will I need to write my own form?
Your application is actually still working while a modal dialog or system message box or similar is active (or while a menu is open), it's just that a secondary message loop is running which processes all messages - all messages sent or posted to it, and it will synthesize (and process) WM_TIMER and WM_PAINT messages when necessary as well.
So there's no need to create a thread or jump through any other hoops, you simply need to schedule the code that closes the message box to be run after those 10 seconds have elapsed. A simple way to do that is to call SetTimer() without a target HWND, but a callback function:
procedure CloseMessageBox(AWnd: HWND; AMsg: UINT; AIDEvent: UINT_PTR;
ATicks: DWORD); stdcall;
var
Wnd: HWND;
begin
KillTimer(AWnd, AIDEvent);
// active window of the calling thread should be the message box
Wnd := GetActiveWindow;
if IsWindow(Wnd) then
PostMessage(Wnd, WM_CLOSE, 0, 0);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
TimerId: UINT_PTR;
begin
TimerId := SetTimer(0, 0, 10 * 1000, #CloseMessageBox);
Application.MessageBox('Will auto-close after 10 seconds...', nil);
// prevent timer callback if user already closed the message box
KillTimer(0, TimerId);
end;
Error handling ommitted, but this should get you started.
You can try to do it with a standard Message dialog. Create the dialog with CreateMessageDialog procedure from Dialogs and after add the controls that you need.
In a form with a TButton define onClick with this:
procedure TForm1.Button1Click(Sender: TObject);
var
tim:TTimer;
begin
// create the message
AMsgDialog := CreateMessageDialog('This is a test message.',mtWarning, [mbYes, mbNo]) ;
lbl := TLabel.Create(AMsgDialog) ;
tim := TTimer.Create(AMsgDialog);
counter := 0;
// Define and adding components
with AMsgDialog do
try
Caption := 'Dialog Title' ;
Height := 169;
// Label
lbl.Parent := AMsgDialog;
lbl.Caption := 'Counting...';
lbl.Top := 121;
lbl.Left := 8;
// Timer
tim.Interval := 400;
tim.OnTimer := myOnTimer;
tim.Enabled := true;
// result of Dialog
if (ShowModal = ID_YES) then begin
Button1.Caption := 'Press YES';
end
else begin
Button1.Caption := 'Press NO';
end;
finally
Free;
end;
end;
An the OnTimer property like this:
procedure TForm1.MyOnTimer(Sender: TObject);
begin
inc(counter);
lbl.Caption := 'Counting: ' + IntToStr(counter);
if (counter >= 5) then begin
AMsgDialog.Close;
end;
end;
Define the variables and procedure:
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
AMsgDialog: TForm;
lbl:TLabel;
counter:integer;
procedure MyOnTimer(Sender: TObject);
end;
And test it.
The form close automatically when the timer final the CountDown. Similar this you can add other type of components.
Regards.
Try this:
function MessageBoxTimeOut(hWnd: HWND; lpText: PChar; lpCaption: PChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): integer;
stdcall; external user32 name 'MessageBoxTimeoutA';
I've been using this for quite some time; it works a treat.
OK. You have 2 choices:
1 - You can create your own MessageDialog form. Then, you can use it and add a TTimer that will close the form when you want.
2 - You can keep using showmessage and create a thread that will use FindWindow (to find the messadialog window) and then close it.
I recommend you to use you own Form with a timer on it. Its cleaner and easier.
This works fine with windows 98 and newers...
I don't use the " MessageBoxTimeOut" because old windows 98, ME, doesn't have it...
this new function works like a "CHARM"..
//add this procedure
procedure DialogBoxAutoClose(const ACaption, APrompt: string; DuracaoEmSegundos: Integer);
var
Form: TForm;
Prompt: TLabel;
DialogUnits: TPoint;
ButtonTop, ButtonWidth, ButtonHeight: Integer;
nX, Lines: Integer;
function GetAveCharSize(Canvas: TCanvas): TPoint;
var
I: Integer;
Buffer: array[0..51] of Char;
begin
for I := 0 to 25 do Buffer[I] := Chr(I + Ord('A'));
for I := 0 to 25 do Buffer[I + 26] := Chr(I + Ord('a'));
GetTextExtentPoint(Canvas.Handle, Buffer, 52, TSize(Result));
Result.X := Result.X div 52;
end;
begin
Form := TForm.Create(Application);
Lines := 0;
For nX := 1 to Length(APrompt) do
if APrompt[nX]=#13 then Inc(Lines);
with Form do
try
Font.Name:='Arial'; //mcg
Font.Size:=10; //mcg
Font.Style:=[fsBold];
Canvas.Font := Font;
DialogUnits := GetAveCharSize(Canvas);
//BorderStyle := bsDialog;
BorderStyle := bsToolWindow;
FormStyle := fsStayOnTop;
BorderIcons := [];
Caption := ACaption;
ClientWidth := MulDiv(Screen.Width div 4, DialogUnits.X, 4);
ClientHeight := MulDiv(23 + (Lines*10), DialogUnits.Y, 8);
Position := poScreenCenter;
Prompt := TLabel.Create(Form);
with Prompt do
begin
Parent := Form;
AutoSize := True;
Left := MulDiv(8, DialogUnits.X, 4);
Top := MulDiv(8, DialogUnits.Y, 8);
Caption := APrompt;
end;
Form.Width:=Prompt.Width+Prompt.Left+50; //mcg fix
Show;
Application.ProcessMessages;
finally
Sleep(DuracaoEmSegundos*1000);
Form.Free;
end;
end;
////////////////////////////How Call It//////////////////
DialogBoxAutoClose('Alert'', "This message will be closed in 10 seconds',10);
/////////////////////////////////////////////////////////
MessageBox calls this function internally and pass 0xFFFFFFFF as timeout parameter, so the probability of it being removed is minimal (thanks to Maurizio for that)
I thought about using a separate thread, but it's probably going to get you into a lot of unnecessary code etc. Windows dialogs were simply not made for this thing.
You should do your own form. On the good side, you can have custom code/UI with a countdown like timed dialog boxes do.
No. ShowMessage and MessageDlg are both modal windows, which means that your application is basically suspended while they're displayed.
You can design your own replacement dialog that has a timer on it. In the FormShow event, enable the timer, and in the FormClose event disable it. In the OnTimer event, disable the timer and then close the form itself.
You can hook up the Screen.OnActiveFormChange event and use Screen.ActiveCustomForm if it is a interested form that you want to hook up the timer to close it
{code}
procedure abz.ActiveFormChange(Sender: TObject);
var
Timer: TTimer;
begin
if (Screen.ActiveCutomForm <> nil) and //valid form
(Screen.ActiveCutomForm.Tag = 0) and //not attached a timer yet
(Screen.ActiveCutomForm.ClassName = 'TMessageForm') //any interested form type check
then
begin
Timer := TTimer.Create(Screen.ActiveCutomForm); // let the form owned so it will be freed
Timer.Enabled := False;
Timer.Tag := Integer(Screen.ActiveCutomForm); // keep track to be used in timer event
.... setup any timer interval + event
Screen.ActiveCutomForm.Tag := Integer(Timer);
Timer.Enabled := True;
end;
end;
{code}
enjoy
Best way is to use a stayontop form and manage a counter to disappear using the alfpha blend property of the form, at the end of the count just close the form, but
the control will be passed to the active control needed before showing the form, this way, user will have a message which disappears automatically and wont prevent the usage of the next feature, very cool trick for me.
You can do this with WTSSendMessage.
You can find this in the JWA libraries, or call it yourself.

WM_SysCommand Preventing window move in delphi

I use the following code to capture when the minimise button of my program is pressed so that I can hide the form from the taskbar, and as such minimise to the system tray.
procedure TForm1.WMSysCommand;
begin
if (Msg.CmdType = SC_MINIMIZE) then
begin
form1.Hide;
show1.Checked :=false;
hide1.Checked :=true;
end;
if (Msg.CmdType = SC_CLOSE) then form1.Close;
end;
I have had to put the capture in for the close button too as this code was preventing the program closing via the close button. What I need help with is how to fix dragging the program window by the caption bar which has stopped working with this code.
If you override the processing of a Windows message you need to take care to either handle all possible cases, or to call the inherited code for all unhandled cases:
procedure TForm1.WMSysCommand(var Msg: TWMSysCommand);
begin
if (Msg.CmdType = SC_MINIMIZE) then
begin
Hide;
show1.Checked := False;
hide1.Checked := True;
Msg.Result := 0;
exit;
end;
inherited;
end;

Resources