im working on a little Project right now and i want to synchronize 5 listBoxes scrolling together. The names of the listboxes are:
KidList
PointList
NoteList
CommentList
CommentListKid
How can i do it?
You could try the following technique.
First, add a private field
private
SyncBoxes: TArray<TListBox>;
to your form and initialise it when the form is created:
procedure TForm1.FormCreate(Sender: TObject);
begin
SyncBoxes := [ListBox1, ListBox2, ListBox3, ListBox4];
end;
Then define the following interposer class:
type
TListBox = class(Vcl.StdCtrls.TListBox)
strict private
procedure Sync;
protected
procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
procedure WMMouseWheel(var Message: TWMMouseWheel); message WM_MOUSEWHEEL;
end;
implemented as
procedure TListBox.CNCommand(var Message: TWMCommand);
begin
inherited;
if Message.NotifyCode = LBN_SELCHANGE then
Sync;
end;
procedure TListBox.Sync;
var
LB: TListBox;
begin
for LB in Form1.SyncBoxes do
if LB <> Self then
LB.TopIndex := Self.TopIndex;
end;
procedure TListBox.WMMouseWheel(var Message: TWMMouseWheel);
begin
inherited;
Sync;
end;
procedure TListBox.WMVScroll(var Message: TWMVScroll);
begin
inherited;
Sync;
end;
Of course, in a real app you would refactor this.
The result is possibly good enough:
The list box's scrolling animation makes synchronisation a little bit delayed, however.
Related
I have a simple form that only contains a TTouchKeyboard. The forms BorderStyle is set to bsToolWindow. To avoid the form getting focus when clicking the touch keyboard I handle the WM_MOUSEACTIVATE message with this implementation:
procedure TKeyboardForm.WMMouseActivate(var Message: TWMMouseActivate);
begin
Message.Result := MA_NOACTIVATE;
end;
The BorderStyle setting allows the form to be dragged with the title bar, but in that case the form still gets the focus. Is there a way to avoid this?
Update: I tried adding WS_EX_NOACTIVATE to ExStyle in CreateParams, but unfortunately that doesn't hinder the form to receive focus when dragged.
procedure TKeyboardForm.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.ExStyle := Params.ExStyle or WS_EX_NOACTIVATE;
end;
Because I was not very pleased with the approach that requires me to manually update the focused form variable in the keyboard form, I searched for a more transparent solution and came up with this approach.
Update: The previous approach had some issues with VCL styles. In addition not all of the message handlers were really necessary, though others turned out to be helpful, too. This version works well with VCL styles avoiding any flicker as far as possible:
type
TKeyboardForm = class(TForm)
TouchKeyboard1: TTouchKeyboard;
private
FLastFocusedForm: TCustomForm;
procedure SetLastFocusedForm(const Value: TCustomForm);
protected
procedure WMActivate(var Message: TWMActivate); message WM_ACTIVATE;
procedure WMMouseActivate(var Message: TWMMouseActivate); message WM_MOUSEACTIVATE;
procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
property LastFocusedForm: TCustomForm read FLastFocusedForm write SetLastFocusedForm;
public
class constructor Create;
destructor Destroy; override;
function SetFocusedControl(Control: TWinControl): Boolean; override;
end;
type
TKeyboardFormStyleHook = class(TFormStyleHook)
protected
procedure WMNCActivate(var Message: TWMNCActivate); message WM_NCACTIVATE;
end;
procedure TKeyboardFormStyleHook.WMNCActivate(var Message: TWMNCActivate);
begin
{ avoids the title bar being drawn active for blink }
Message.Active := False;
inherited;
end;
class constructor TKeyboardForm.Create;
begin
TCustomStyleEngine.RegisterStyleHook(TKeyboardForm, TKeyboardFormStyleHook);
end;
destructor TKeyboardForm.Destroy;
begin
LastFocusedForm := nil;
inherited;
end;
procedure TKeyboardForm.Notification(AComponent: TComponent; Operation: TOperation);
begin
if (Operation = opRemove) and (AComponent = FLastFocusedForm) then begin
FLastFocusedForm := nil;
end;
inherited;
end;
function TKeyboardForm.SetFocusedControl(Control: TWinControl): Boolean;
begin
LastFocusedForm := Screen.FocusedForm;
result := inherited;
end;
procedure TKeyboardForm.SetLastFocusedForm(const Value: TCustomForm);
begin
if FLastFocusedForm <> Value then
begin
if FLastFocusedForm <> nil then begin
FLastFocusedForm.RemoveFreeNotification(Self);
end;
FLastFocusedForm := Value;
if FLastFocusedForm <> nil then begin
FLastFocusedForm.FreeNotification(Self);
end;
end;
end;
procedure TKeyboardForm.WMActivate(var Message: TWMActivate);
begin
Message.Active := WA_INACTIVE;
inherited;
end;
procedure TKeyboardForm.WMMouseActivate(var Message: TWMMouseActivate);
begin
inherited;
Message.Result := MA_NOACTIVATE;
end;
procedure TKeyboardForm.WMSetFocus(var Message: TWMSetFocus);
begin
inherited;
if (FLastFocusedForm <> nil) and (message.FocusedWnd <> FLastFocusedForm.Handle) then begin
SendMessage(FLastFocusedForm.Handle, WM_SETFOCUS, 0, 0);
Message.FocusedWnd := FLastFocusedForm.Handle;
end;
end;
The following combination of WMMouseActivate(), WMNCActivate() and reseting focus seems to fulfill your wishes:
The keyboard form (with BorderStyle = bsToolWindow) has message handlers for WM_MOUSEACTIVATE (as you already have) and WM_NCACTIVATE. The latter for having a point where to reset focus to the window with the edit control.
In addition the keyboardform will keep track of which form holds the edit (or other) control that has focus, and does that by introducing a new method for showing, which I called ShowUnfocused() and a field called FocusedForm: THandle.
procedure TKbdForm.ShowUnfocused(FocusedWindow: THandle);
begin
FocusedForm := FocusedWindow;
Show;
end;
procedure TKbdForm.FormShow(Sender: TObject);
begin
SetForegroundWindow(FocusedForm);
end;
procedure TKbdForm.WMMouseActivate(var Message: TWMMouseActivate);
begin
Message.Result := MA_NOACTIVATE;
end;
procedure TKbdForm.WMNCActivate(var Message: TWMNCActivate);
begin
Message.Result := 1; // important
SetForegroundWindow(FocusedForm);
end;
The keyboardform is invoked by the following common code of the edit controls:
procedure TForm17.EditClick(Sender: TObject);
begin
KbdForm.ShowUnfocused(self.Handle);
(Sender as TWinControl).SetFocus;
end;
An alternative to what is said above, could be to set the BorderStyle = bsNone and arrange the dragging of the form with the Mouse Down, Move, Up events directly from the forms surface (or maybe a panel to mimic a top frame), and adding a close button. The challenge would be to get it visually acceptable.
I use Delphi 7 and I have a TFrame (hosted by a TForm) with three panels that span over the whole surface, in a "upside down T" layout.
The panels should be resizeable, so I could use 2 splitters, but I want to give a better user experience: I'd like to have a single "size grip" in the T junction.
This "handle" should appear only when the user hovers the junction area.
So here is my question: what is the best way to have a control show on top of any other on mouse move?
TFrame.OnMouseMove don't get called (obviously) because there are the panels inside and possibly any sort of other controls inside them.
I also strongly want to keep all the code inside the frame.
I see 2 solutions:
Install a local Mouse Hook and go with it. But there could be some
performance issues (or not?)
Handle TApplication.OnMessage inside
the frame, but adding some other code in order to simulate a "chain"
of event handlers. This is because other parts of the application
could need to handle TApplication.OnMessage for their own purposes.
Any other idea?
Thank you
To make a mouse move event notifier for the whole frame, no matter which child control is hovered, you can write a handler for the WM_SETCURSOR message as I've learnt from TOndrej in this post. From such event handler you can then determine which control is hovered and bring it to front.
Please note, I have done quite commonly used mistake here. The GetMessagePos result must not be read this way. It's even explicitly mentioned in docs. I don't have Windows SDK to see the MAKEPOINTS macro, so I'll fix this later:
type
TFrame1 = class(TFrame)
// there are many controls here; just pretend :-)
private
procedure WMSetCursor(var Msg: TWMSetCursor); message WM_SETCURSOR;
end;
implementation
procedure TFrame1.WMSetCursor(var Msg: TWMSetCursor);
var
MsgPos: DWORD;
Control: TWinControl;
begin
inherited;
MsgPos := GetMessagePos;
Control := FindVCLWindow(Point(LoWord(MsgPos), HiWord(MsgPos)));
if Assigned(Control) then
Control.BringToFront;
end;
I'll post this self-answer just because it works and it could be useful in some cases, but I marked TLama's as the best answer.
This is the solution 2) of the question:
TMyFrame = class(TFrame)
// ...design time stuff...
private
FMouseHovering: Boolean;
FPreviousOnAppMessage: TMessageEvent;
procedure DoOnAppMessage(var Msg: TMsg; var Handled: Boolean);
protected
procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
implementation
constructor TMyFrame.Create(AOwner: TComponent);
begin
inherited;
FMouseHovering := False;
FPreviousOnAppMessage := Application.OnMessage;
Application.OnMessage := DoOnAppMessage;
end;
destructor TMyFrame.Destroy;
begin
Application.OnMessage := FPreviousOnAppMessage;
inherited;
end;
procedure TRiascoFrame.CMMouseEnter(var Message: TMessage);
begin
FMouseHovering := True;
end;
procedure TRiascoFrame.CMMouseLeave(var Message: TMessage);
begin
FMouseHovering := False;
end;
procedure TMyFrame.DoOnAppMessage(var Msg: TMsg; var Handled: Boolean);
begin
if (Msg.message = WM_MOUSEMOVE) and FMouseHovering then
DoHandleMouseMove(Msg.hwnd, Integer(LoWord(Msg.lParam)), Integer(HiWord(Msg.lParam)));
if Assigned(FPreviousOnAppMessage) then
FPreviousOnAppMessage(Msg, Handled);
end;
procedure TMyFrame.DoHandleMouseMove(hWnd: HWND; X, Y: Integer);
var
ClientPoint: TPoint;
begin
ClientPoint := Point(X, Y);
Windows.ClientToScreen(hwnd, ClientPoint);
Windows.ScreenToClient(Self.Handle, ClientPoint);
if PtInRect(ClientRect, ClientPoint) then
begin
// ...do something...
end;
end;
I have set up a global exception handler in Delphi. On some severe exceptions an error message is displayed (followed by Halt()). While the error message is shown, Delphi is processing the message queue, processing timer events, that lead to further errors.
What I want is to show an error dialog which does not process timer events. How is that possible in Delphi?
Edit: I use Dialogs.MessageDlg(...) to display the message.
You can filter queued messages, such as WM_TIMER, with TApplication.OnMessage.
procedure TMainForm.ApplicationMessage(var Msg: TMsg; var Handled: Boolean);
begin
if ShowingFatalErrorDialog then
if Msg.Message = WM_TIMER then
Handled := True;
end;
Either assign that event handler directly to Application.OnMessage or use a TApplicationEvents object.
Obviously you'll have to provide the implementation for ShowingFatalErrorDialog but I trust that it is obvious to you how to do so.
Try something like this:
...
private
FAboutToTerminate: Boolean;
end;
...
type
ESevereError = class(Exception);
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Tag := Tag + 1;
if Tag > 2 then
raise ESevereError.Create('Error');
end;
procedure TForm1.ApplicationEvents1Exception(Sender: TObject;
E: Exception);
begin
if (E is ESevereError) and (not FAboutToTerminate) then
begin
FAboutToTerminate := True;
Application.ShowException(E);
Application.Terminate;
end;
end;
Just for reference: I will use the following code, which is a mixture from both answers.
procedure SaveShowErrorMessage(...)
begin
with TFatalErrorAppEvents.Create(nil) do //avoid timer and further exceptions
try
Dialogs.MessageDlg(...);
finally
Free;
end;
end;
With TFatalErrorAppEvents as follows:
type
TFatalErrorAppEvents = class(TApplicationEvents)
protected
procedure KillTimerMessages(var Msg: tagMSG; var Handled: Boolean);
procedure IgnoreAllExceptions(Sender: TObject; E: Exception);
public
constructor Create(AOwner: TComponent); override;
end;
constructor TFatalErrorAppEvents.Create(AOwner: TComponent);
begin
inherited;
OnMessage := KillTimerMessages;
OnException := IgnoreAllExceptions;
end;
procedure TFatalErrorAppEvents.IgnoreAllExceptions(Sender: TObject; E: Exception);
begin
//in case of an Exception do nothing here to ignore the exception
end;
procedure TFatalErrorAppEvents.KillTimerMessages(var Msg: tagMSG; var Handled: Boolean);
begin
if (Msg.message = WM_TIMER) then
Handled := True;
end;
I was hoping for some help with regards to a transparent TMemo control in Delphi 7. I found some code online that works well, to an extent, the refresh rate is a bit rubbish but I can live with that. The main problem is that unselected text can look as if it's actually selected.
Here's where all the text is selected using SelectAll();
Here's where no text is actually selected, but has been previously, note the floating line suggesting typing will happen after the 'p' in Improvement.
And finally an image just showing the difference.
What I find quite odd is that if I hit an arrow key for example, the false highlighting disappears, but when using the mouse it does not.
The code for this custom TMemo is as follows:
unit TrMemo;
interface
uses
Messages, Controls, StdCtrls, classes;
const TMWM__SpecialInvalidate=WM_USER+1111;
type
TTransparentMemo = class(TMemo)
private
procedure SpecialInvalidate(var Message:TMessage); message TMWM__SpecialInvalidate;
procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
procedure WMSetText(var Message:TWMSetText); message WM_SETTEXT;
procedure CNCTLCOLOREDIT(var Message:TWMCTLCOLOREDIT); message CN_CTLCOLOREDIT;
procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
protected
procedure CreateParams(var Params: TCreateParams); override;
public
constructor Create(AOwner: TComponent); override;
end;
procedure Register;
implementation
uses Windows;
{ TTransparentMemo }
procedure TTransparentMemo.WMHScroll(var Message: TWMHScroll);
begin
inherited;
PostMessage(Handle,TMWM__SpecialInvalidate,0,0);
end;
procedure TTransparentMemo.WMVScroll(var Message: TWMVScroll);
begin
SendMessage(Handle,TMWM__SpecialInvalidate,0,0);
inherited;
PostMessage(Handle,TMWM__SpecialInvalidate,0,0);
end;
procedure TTransparentMemo.CNCTLCOLOREDIT(var Message:TWMCTLCOLOREDIT);
begin
with Message do
begin
SetBkMode(ChildDC,TRANSPARENT);
Result:=GetStockObject(HOLLOW_BRUSH)
end
end;
procedure TTransparentMemo.WMSetText(var Message:TWMSetText);
begin
inherited;
if not (csDesigning in ComponentState) then PostMessage(Handle,TMWM__SpecialInvalidate,0,0)
end;
procedure TTransparentMemo.SpecialInvalidate(var Message:TMessage);
var
r:TRect;
begin
if (Parent <> nil) then
begin
r:=ClientRect;
r.TopLeft:=Parent.ScreenToClient(ClientToScreen(r.TopLeft));
r.BottomRight:=Parent.ScreenToClient(ClientToScreen(r.BottomRight));
InvalidateRect(Parent.Handle,#r,true);
RedrawWindow(Handle,nil,0,RDW_FRAME+RDW_INVALIDATE);
end;
end;
procedure TTransparentMemo.WMKeyDown(var Message: TWMKeyDown);
begin
SendMessage(Handle,TMWM__SpecialInvalidate,0,0);
inherited;
PostMessage(Handle,TMWM__SpecialInvalidate,0,0);
end;
procedure TTransparentMemo.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result:=1
end;
constructor TTransparentMemo.Create(AOwner: TComponent);
begin
inherited;
ControlStyle:=[csCaptureMouse, csDesignInteractive, csClickEvents, csSetCaption, csOpaque, csDoubleClicks, csReplicatable, csNoStdEvents];
end;
procedure TTransparentMemo.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
begin
ExStyle:=ExStyle or WS_EX_TRANSPARENT and not WS_EX_WINDOWEDGE
and not WS_EX_STATICEDGE and not WS_EX_DLGMODALFRAME and not
WS_EX_CLIENTEDGE;
end;
end;
procedure Register;
begin
RegisterComponents('Samples', [tTransparentMemo]);
end;
end.
Any tips/hints/answers would be greatly appreciated! Cheers in advance!
This isn't a complete fix, but you could, for example, do something like
protected
procedure Click; override;
procedure TTransparentMemo.Click;
begin
PostMessage(Handle,TMWM__SpecialInvalidate,0,0);
inherited;
end;
And so on. Perhaps there's a better place to do this. Have a look in your VCL source (StdCtrls.pas) and you might find something in TCustomEdit or TCustomMemo which would be better options to override.
I'm trying to write a component, to send string messages between applications by WM_COPYDATA.
I'd like trap the WM_COPYDATA, but this doesn't work:
TMyMessage = class(TComponent)
private
{ Private declarations }
…
protected
{ Protected declarations }
…
procedure WMCopyData(var Msg : TMessage); message WM_COPYDATA;
…
end;
Searching Google a lot, found some reference using wndproc. I tried it, but it isn't working either.
TMyMessage = class(TComponent)
…
protected
{ Protected declarations }
…
procedure WMCopyData(var Msg : TMessage); message WM_COPYDATA;
procedure WndProc(var Msg: TMessage);
…
end;
…
procedure TMyMessage.WndProc(var Msg: TMessage);
begin
//inherited;
if Msg.Msg = WM_COPYDATA then
WMCopyData(Msg);
end;
Please help, what is wrong?
What you have so far is fine, but you need to arrange for messages to be delivered to your component in the first place. That requires a window handle. Call AllocateHWnd and pass it your component's WndProc method. It will return a window handle, which you should destroy as your component is destroyed.
constructor TMyMessage.Create(AOwner: TComponent);
begin
inhreited;
FHandle := AllocateHWnd(WndProc);
end;
destructor TMyMessage.Destroy;
begin
DeallocateHWnd(FHandle);
inherited;
end;
Rather than testing for each message directly, you can let TObject do that for you. That's what the Dispatch method is for. Pass it a TMessage record, and it will find and call the corresponding message-handler method for you. If there is no such handler, it will call DefaultHandler instead. Override that can call DefWindowProc.
procedure TMyMessage.WndProc(var Message);
begin
Dispatch(Message);
end;
procedure TMyMessage.DefaultHandler(var Message);
begin
TMessage(Message).Result := DefWindowProc(Self.Handle, TMessage(Message).Msg,
TMessage(Message).WParam, TMessage(Message).LParam);
end;
Your problem is that TComponent is not a windowed component. WM_COPYDATA is a windows message and is delivered via a window procedure. Hence you need a window handle. Use AllocateHwnd to get hold of one of these.
type
TMyComponent = class(TComponent)
private
FWindowHandle: HWND;
procedure WndProc(var Msg: TMessage);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
constructor TMyComponent.Create(AOwner: TComponent);
begin
inherited;
FWindowHandle := AllocateHwnd(WndProc);
end;
destructor TMyComponent.Destroy;
begin
DeallocateHwnd(FWindowHandle);
inherited;
end;
procedure TMyComponent.WndProc(var Msg: TMessage);
begin
if Msg.Msg=WM_COPYDATA then
//do domething
else
Msg.Result := DefWindowProc(FWindowHandle, Msg.Msg, Msg.WParam, Msg.LParam);
end;
Whatever is sending the messages will need to find a way to get hold of the window handle.
I did it this way:
My web modules which are running in a thread need to send strings to a memo on the main form.
FReceiverFromWS is a THandle
On create:
procedure TWebModuleWebServices.WebModuleCreate(Sender: TObject);
begin
FReceiverFromWS := FindWindow(PChar('TFormWebServices'),PChar(cFormCaption + FormWebServices.Instance)); // Search by class name and caption of receiving form
// ==> you could to that without form caption, but I need to distinguish between running services
if FReceiverFromWS = 0 then
begin
Assert(False,'CopyData receiver NOT found!'); // Probably TFormWebServices not yet created
Exit;
end;
end;
To send messages:
procedure TWebModuleWebServices.SendAMessage(Msg: String);
// Windows will guarantee that the data sent in the COPYDATASTRUCT will exist until after the WM_COPYDATA message
// has been carried out. As such, we must use SendMessage() to send a WM_COPYDATA message. We cannot use PostMessage().
var
lCopyDataStruct: TCopyDataStruct;
begin
lCopyDataStruct.dwData := 0;
lCopyDataStruct.cbData := 1 + Length(Msg);
lCopyDataStruct.lpData := PChar(Msg);
SendMessage(FReceiverFromWS, WM_COPYDATA, wParam(FReceiverFromWS), lParam(#lCopyDataStruct));
end;
In the main form, public method
procedure WMCopyData(var Msg : TWMCopyData) ; message WM_COPYDATA;
is:
procedure TFormWebServices.WMCopyData(var Msg: TWMCopyData);
var
i : integer;
s : string;
begin
i := Msg.CopyDataStruct.dwData;
case i of
0: begin // Message to display
s := String(PChar(Msg.CopyDataStruct.lpData));
AddMemoLine(s);
end;
1: begin // Statistical data
s := String(PChar(Msg.CopyDataStruct.lpData));
FrmWebServiceStats.CollectStats(s);
end;
end;
end;
(As you can see, I actually use dwData to signal the kind of message and handle these differently)