I use the Gecko SDK, a component that allows you to view web pages.
I use this component to create an html editor.
This problem happens when going off editing web pages.
The problem is that the arrow keys and the tab does not work with my component. I tried to find an answer to this problem, but I didn't find one. I found a track here, but the function does not work.
Function Movement (dx, dy) does not exist. Thank you for helping me solve this problem.
Procedure Tform1.TraiteMessages(Var msg : TMsg; Var Handled: boolean);
var
dx, dy : integer;
begin dx: 0; dy := 0;
With msg do
begin
IF Message = WM_KEYDOWN then
Case wparam of
VK_LEFT : dx := -1;
VK_RIGHT : dx := 1;
VK_UP : dy := -1;
VK_DOWN : dy := 1;
end;
end;
IF (dy = 0) AND (Dx = 0) then Handled := false else
begin
handled := true; // message traité
Mouvement(dx, dy) // exécution du tracé
end;
end;
Add this to your component's class:
procedure HandleDlgCode(var Msg:TMessage); message WM_GETDLGCODE;
and then in the implementation section:
procedure TComponentClass.HandleDlgCode(var Msg:TMessage);
var
M: PMsg;
begin
Msg.Result := DLGC_WANTALLKEYS or DLGC_WANTARROWS or DLGC_WANTCHARS or DLGC_HASSETSEL;
if Msg.lParam <> 0 then
begin
M := PMsg(Msg.lParam);
case M.message of
WM_KEYDOWN, WM_KEYUP, WM_CHAR:
begin
Perform(M.message, M.wParam, M.lParam);
Msg.Result := Msg.Result or DLGC_WANTMESSAGE;
end;
end;
end
else
Msg.Result := Msg.Result or DLGC_WANTMESSAGE;
end;
I've just copy-pasted this code from my own numeric editor, so it works.
This is not the way it is done!
This is the way we did things before Delphi, in 1996.
There no need for this complicated Windows stuff.
You are making an editor.
Delphi already has 2 editors build-in.
TMemo
TRichEdit.
Start with TMemo as your parent, and you have a ready made editor, no need to capture cursor keys.
interface
type
TMyComponent = class(TMemo)
// ^^^^^^^^^^^^^^^^^^^^<<- use this as your parent class
protected
procedure KeyPress(var Key: Char); override
...
implementation
procedure TMyComponent.KeyPress(var Key: Char);
begin
inherited;
//it works just like this, TMemo does everything.
end;
In fact you can leave out KeyPress and start working on other stuff.
No need to use lowlevel code. You are doing it too complex.
Get a book an delphi component design. Even for an older Delphi, not much has changed.
Every hour spend reading a book on this subject will save 20 hours of coding time.
Good luck.
Procedure Tform1.TraiteMessages(Var msg : TMsg; Var Handled: boolean);
var
dx, dy : integer;
begin
dx := 0;
dy := 0;
With msg do
begin
IF Message = WM_KEYDOWN then
begin
Case wparam of
VK_LEFT : dx := -1;
VK_RIGHT : dx := 1;
VK_UP : dy := -1;
VK_DOWN : dy := 1;
end;
end;
end;
Mouvement(dx, dy);
Handled := ((dy <> 0) or (dx <> 0));
end;
That cleans up your method... now, you should place a breakpoint on your IF statement, and another on your Case conditions to determine first and foremost if your message hook is ever being triggered, but also if the message being handled is what you would expect.
Does your component properly catch Key events? Do you have another visual component focused? Have you set your form's "KeyPreview" property to True?
You may also want to try using a TApplicationEvents control to deal with your key message hook (if your component is non-visual).
Take a look at this unit on my SVN repository (username and password are both "anon" without quotes) as it demonstrates how to intercept and handle key inputs even on non-visual components.
Hope this helps, and good luck!
Related
this problem is driving me crazy, i have an edit box in which i write something. On event 'change' of edit box, a ListBox is created and filled by SQL query. It works as a hint box while writing.
When i hit enter on the item which i want to select, the listbox should 'free', but it continues to return me 'access violation'. Here the code:
procedure TFTimbra.EditCommessaKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
var
X, Y, W: Integer;
QSugg: TAdoQuery;
begin
if not Assigned(Suggerimento) then
begin
Suggerimento := TListBox.Create(Self);
Y := EditCommessa.Top + EditCommessa.Height;
X := EditCommessa.Left;
W := EditCommessa.Width;
with Suggerimento do
begin
Top := Y;
Left := X;
Width := W;
Height := 200;
Parent := FTimbra;
BorderStyle := bsNone;
Font.Size := 14;
Font.Style := [fsBold];
end;
end else
Suggerimento.Clear;
if Key = 40 then
Suggerimento.SetFocus;
QSugg := TAdoQuery.Create(nil);
QSugg.ConnectionString := DMMain.DBConnection.ConnectionString;
QSugg.SQL.Text := format('select Codice, Descrizione from Commesse where Descrizione like %s',
[quotedstr('%' + EditCommessa.Text + '%')]);
QSugg.Open;
while not QSugg.Eof do
begin
Suggerimento.Items.Add(QSugg.FieldByName('Descrizione').AsString);
QSugg.Next;
end;
QSugg.Close;
if Assigned(Suggerimento) then Suggerimento.OnKeyDown := SuggerimentoKeyDown;
end;
This is the first part, and this is the code that "should" free the listbox:
procedure TFTimbra.SuggerimentoKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key = 13 then
begin
Commessa := Suggerimento.Items[Suggerimento.ItemIndex];
EditCommessa.Text := Commessa;
Suggerimento.Free;
end;
end;
I think the problem is in the call of the OnKeyDown function.. Thank you in advance.
You can't destroy an object from one of that object's own event handlers. When the event handler returns, the code continues executing in the context of the object, which you just freed. And that typically leads to runtime errors like this.
Rather than use a dynamic lifetime for this list box control, create it in the traditional way, using the form designer. When you want it hidden, set Visible to False. When you want it to show, set Visible to True.
I'm using Delphi to develop a DBLookupComboBox component with your own SQL (using Devart UniDac), without external ListSource, ListField, KeyField. Everything is working perfectly fine, but for a better user interface, I need one small detail.
I always leave the selected text according to the user's typing. When characters are typed, all right; but, when movement keys are typed (VK_LEFT, VK_RIGHT, combinations and etc.), the process is not cool, because the SelStart/SelLength places the cursor at the end of the text (sellength) and I want the cursor in the left (at SelStart), next to the last letter typed.
The component (using TFrame, TEdit and etc).
User typed BIAN, my component find the first person and use SelStart/SelLength to highlight.
User typed VK_LEFT, my component should show this:
But show this:
Unfortunately, the SelStart/SelLength properties to not support what you are asking for. Despite what MSDN documentation claims, the caret is always placed on the right side of the selection.
However, there is a simple trick you can use to place the caret on the left side of the selection instead:
procedure SelectText(Edit: TCustomEdit; iFirst, iLast: Integer);
var
bState: TKeyboardState;
bNewState: TKeyboardState;
i: Integer;
begin
if iFirst <= iLast then begin
{
Edit.SelStart := iFirst;
Edit.SelLength := iLast - iFirst;
}
SendMessage(Edit.Handle, EM_SETSEL, iFirst, iLast);
end else
begin
//Edit.SelStart := iFirst;
SendMessage(Edit.Handle, EM_SETSEL, iFirst, iFirst);
if GetKeyboardState(bState) then
begin
bNewState := bState;
bNewState[VK_SHIFT] := bNewState[VK_SHIFT] or 128;
if SetKeyboardState(bNewState) then
begin
repeat
SendMessage(Edit.Handle, WM_KEYDOWN, VK_LEFT, 0);
Dec(iFirst);
until iFirst = iLast;
SendMessage(Edit.Handle, WM_KEYUP, VK_LEFT, 0);
SetKeyboardState(bState);
end;
end;
end;
end;
Alternatively:
procedure SelectText(Edit: TEdit; iFirst, iLength: Integer);
var
bState: TKeyboardState;
bNewState: TKeyboardState;
i: Integer;
begin
if iLength >= 0 then begin
{
Edit.SelStart := iFirst;
Edit.SelLength := iLength;
}
SendMessage(Edit.Handle, EM_SETSEL, iFirst, iFirst + iLength);
end else
begin
//Edit.SelStart := iFirst;
SendMessage(Edit.Handle, EM_SETSEL, iFirst, iFirst);
if GetKeyboardState(bState) then
begin
bNewState := bState;
bNewState[VK_SHIFT] := bNewState[VK_SHIFT] or 128;
if SetKeyboardState(bNewState) then
begin
repeat
SendMessage(Edit.Handle, WM_KEYDOWN, VK_LEFT, 0);
Inc(iLength);
until iLength = 0;
SendMessage(Edit.Handle, WM_KEYUP, VK_LEFT, 0);
SetKeyboardState(bState);
end;
end;
end;
end;
Depending on whether you want to define the selection using absolute start/end positions, or a start position and a length.
Basically, what this code is doing is if the ending position is lower than the starting position, the code places the caret at the starting right side position and then simulates Shift+Left key presses until the caret reaches the desired left side position.
I am trying to upgrade my application from Delphi 2007 to Delphi 10 Seattle. I understand that a record needs to be copied to a local variable before changing and then assigned back. I am trying the same but I still get the error that I cannot assign to a left side. Could someone please help.
procedure TMydlg.WMGetMinMaxInfo(var Msg:TMessage);
var
MinMaxInfo: TMinMaxInfo;
begin
inherited;
MinMaxInfo := (PMinMaxInfo(Msg.LParam)^);
with MinMaxInfo do
begin
ptMinTrackSize.X := MinWidth;
ptMinTrackSize.Y := MinHeight;
ptMaxTrackSize.X := MinWidth;
end;
// Error here. Left side cannot be assigned to
(PMinMaxInfo(Msg.LParam)^) := MinMaxInfo;
TMinMaxInfo is from Winapi.windows
The compiler error is emitted because the compiler rejects the outermost parens on the left hand side of the final assignment. In essence, your code is akin to the following:
type
TMyRecord = record
end;
procedure Foo;
var
rec1, rec2: TMyRecord;
begin
rec1 := rec2; // compiles
(rec1) := rec2; // E2064 Left side cannot be assigned to
end;
Writing it in this simplified manner brings the issue into very sharp relief.
I'm not sure why the compiler rejects these parens. I suspect that the formal grammar of the language renders your left hand side invalid. Serg provides a plausible explanation in the comments, that is that (...) is an expression, and an expression is not valid as the left hand side of an assignment. I'm inclined to believe that is accurate.
Anyway, it is simple to fix your code. Instead of
(PMinMaxInfo(Msg.LParam)^) := MinMaxInfo;
write
PMinMaxInfo(Msg.LParam)^ := MinMaxInfo;
Note that it is not necessary to make a copy of the record, modify it, and then copy it back. You can modify the record directly, once you have cast LParam to a pointer to the record.
I would do so like this:
procedure TMydlg.WMGetMinMaxInfo(var Msg:TMessage);
var
pmmi: PMinMaxInfo;
begin
inherited;
pmmi := PMinMaxInfo(Msg.LParam);
pmmi.ptMinTrackSize.X := MinWidth;
pmmi.ptMinTrackSize.Y := MinHeight;
pmmi.ptMaxTrackSize.X := MinWidth;
end;
I've omitted the ^ pointer dereference operator since it is optional in this scenario. If you prefer you might write the assignments like this:
pmmi^.ptMinTrackSize.X := MinWidth;
pmmi^.ptMinTrackSize.Y := MinHeight;
pmmi^.ptMaxTrackSize.X := MinWidth;
It is because you do not use a Record type and not a pointer type.
Change your code to this:
procedure TMydlg.WMGetMinMaxInfo(var Msg: TMessage);
begin
with pMinMaxInfo(Msg.LParam)^ do
begin
ptMinTrackSize.X := MinWidth;
ptMinTrackSize.Y := MinHeight;
ptMaxTrackSize.X := MinWidth;
end;
end;
I've created a dummy test program:
procedure TForm9.FormCreate(Sender: TObject);
var
MinMaxInfo: pMinMaxInfo;
Msg: TMessage;
begin
MinMaxInfo := new(pMinMaxInfo);
Msg.LParam := integer(MinMaxInfo);
WMGetMinMaxInfo(Msg);
Assert( pMinMaxInfo(Msg.LParam)^.ptMinTrackSize.X = 10);
end;
procedure TForm9.WMGetMinMaxInfo(var Msg: TMessage);
var
MinMaxInfo: pMinMaxInfo;
begin
MinMaxInfo := pMinMaxInfo(Msg.LParam);
with MinMaxInfo^ do
begin
ptMinTrackSize.X := 10;
ptMinTrackSize.Y := 10;
ptMaxTrackSize.X := 10;
end;
end;
I need the opposite information that the question "How to get cursor position on a control?" asks.
Given the current cursor position, how can I find the form (in my application) and the control that the cursor is currently over? I need the handle to it so that I can use Windows.SetFocus(Handle).
For reference, I'm using Delphi 2009.
I experienced some problems with suggested solutions (Delphi XE6/Windows 8.1/x64):
FindVCLWindow doesn't search disabled controls (Enabled=False).
TWinControl.ControlAtPos doesn't search controls if they are disabled
indirectly (for example if Button.Enabled=True, but Button.Parent.Enabled=False).
In my case it was a problem, because i need to find any visible control under the mouse cursor, so i have to use my own implementation of function FindControlAtPos:
function FindSubcontrolAtPos(AControl: TControl; AScreenPos, AClientPos: TPoint): TControl;
var
i: Integer;
C: TControl;
begin
Result := nil;
C := AControl;
if (C=nil) or not C.Visible or not TRect.Create(C.Left, C.Top, C.Left+C.Width, C.Top+C.Height).Contains(AClientPos) then
Exit;
Result := AControl;
if AControl is TWinControl then
for i := 0 to TWinControl(AControl).ControlCount-1 do
begin
C := FindSubcontrolAtPos(TWinControl(AControl).Controls[i], AScreenPos, AControl.ScreenToClient(AScreenPos));
if C<>nil then
Result := C;
end;
end;
function FindControlAtPos(AScreenPos: TPoint): TControl;
var
i: Integer;
f,m: TForm;
p: TPoint;
r: TRect;
begin
Result := nil;
for i := Screen.FormCount-1 downto 0 do
begin
f := Screen.Forms[i];
if f.Visible and (f.Parent=nil) and (f.FormStyle<>fsMDIChild) and
TRect.Create(f.Left, f.Top, f.Left+f.Width, f.Top+f.Height).Contains(AScreenPos)
then
Result := f;
end;
Result := FindSubcontrolAtPos(Result, AScreenPos, AScreenPos);
if (Result is TForm) and (TForm(Result).ClientHandle<>0) then
begin
WinAPI.Windows.GetWindowRect(TForm(Result).ClientHandle, r);
p := TPoint.Create(AScreenPos.X-r.Left, AScreenPos.Y-r.Top);
m := nil;
for i := TForm(Result).MDIChildCount-1 downto 0 do
begin
f := TForm(Result).MDIChildren[i];
if TRect.Create(f.Left, f.Top, f.Left+f.Width, f.Top+f.Height).Contains(p) then
m := f;
end;
if m<>nil then
Result := FindSubcontrolAtPos(m, AScreenPos, p);
end;
end;
I think FindVCLWindow will meet your needs. Once you have the windowed control under the cursor you can walk the parent chain to find the form on which the window lives.
If you want to know the control inside a form that is at a certain x,y coordinate
Use
function TWinControl.ControlAtPos(const Pos: TPoint; AllowDisabled: Boolean;
AllowWinControls: Boolean = False; AllLevels: Boolean = False): TControl;
Given the fact that you seem only interested in forms inside your application, you can just query all forms.
Once you get a non-nil result, you can query the control for its Handle, with code like the following
Pseudo code
function HandleOfControlAtCursor: THandle;
const
AllowDisabled = true;
AllowWinControls = true;
AllLevels = true;
var
CursorPos: TPoint
FormPos: TPoint;
TestForm: TForm;
ControlAtCursor: TControl;
begin
Result:= THandle(0);
GetCursorPos(CursorPos);
for each form in my application do begin
TestForm:= Form_to_test;
FormPos:= TestForm.ScreenToClient(CursorPos);
ControlAtCursor:= TestForm.ControlAtPos(FormPos, AllowDisabled,
AllowWinControls, AllLevels);
if Assigned(ControlAtCursor) then break;
end; {for each}
//Break re-enters here
if Assigned(ControlAtCursor) then begin
while not(ControlAtCursor is TWinControl) do
ControlAtCursor:= ControlAtCursor.Parent;
Result:= ControlAtCursor.Handle;
end; {if}
end;
This also allows you to exclude certain forms from consideration should you so desire. If you're looking for simplicity I'd go with David and use FindVCLWindow.
P.S. Personally I'd use a goto rather than a break, because with a goto it's instantly clear where the break re-enters, but in this case it's not a big issue because there are no statements in between the break and the re-entry point.
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).