I need to disable both mouse buttons on the event OnMouseEnter of a TRichEdit component and enable again on the event OnMouseLeave.
Setting the TRichEdit enabled = false does not solve my problem.
Any tips ?
You can subclass your rich edit so that to intercept mouse button down/up messages. Then you don't need to watch for the mouse entering, leaving the control. Example:
type
TForm1 = class(TForm)
...
private
FSaveRichEditProc: TWndMethod;
procedure RichEditWindowProc(var Message: TMessage);
..
end;
...
procedure TForm1.FormCreate(Sender: TObject);
begin
FSaveRichEditProc := RichEdit1.WindowProc;
RichEdit1.WindowProc := RichEditWindowProc;
end;
procedure TForm1.RichEditWindowProc(var Message: TMessage);
begin
case Message.Msg of
WM_LBUTTONDOWN, WM_LBUTTONUP, WM_LBUTTONDBLCLK,
WM_MBUTTONDOWN, WM_MBUTTONUP, WM_MBUTTONDBLCLK,
WM_RBUTTONDOWN, WM_RBUTTONUP, WM_RBUTTONDBLCLK:
begin
Message.Result := 0;
Exit;
end;
end;
FSaveRichEditProc(Message);
end;
Related
In a 32-bit Delphi 11 VCL Application on Windows 10, I use a TApplicationEvents component to catch Windows Messages. Unfortunately, TApplicationEvents seems to not react to the WM_MENURBUTTONUP message when I RIGHT-CLICK on a TPopupMenu MenuItem:
procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean);
begin
case Msg.message of
Winapi.Messages.WM_MENURBUTTONUP: CodeSite.Send('TForm1.ApplicationEvents1Message: WM_MENURBUTTONUP');
end;
end;
The Microsoft documentation says:
WM_MENURBUTTONUP message
Sent when the user releases the right mouse button while the cursor is on a menu item.
As an alternative, WM_COMMAND is sent with BOTH Left- and Right-Clicks. However, for a specific purpose, I need to react only when RIGHT-Clicking a menu item.
The quoted part of the documentation explains why you aren't seeing this message:
Sent when the user [...]
The TApplicationEvents.OnMessage event is only able to detect posted messages, not sent messages.
TMainMenu
So if you want to detect this message, you can add
protected
procedure WndProc(var Message: TMessage); override;
to your form class, implemented as follows:
procedure TForm1.WndProc(var Message: TMessage);
begin
if Message.Msg = WM_MENURBUTTONUP then
ShowMessage('rbu')
else
inherited
end;
Try, for instance:
procedure TForm1.WndProc(var Message: TMessage);
begin
if Message.Msg = WM_MENURBUTTONUP then
begin
var MI := Menu.FindItem(Message.LParam, fkHandle);
if Assigned(MI) and InRange(Message.WParam, 0, MI.Count - 1) then
ShowMessageFmt('Menu item "%s" right clicked.', [MI.Items[Message.WParam].Caption]);
end
else
inherited
end;
TPopupMenu
For a TPopupMenu, you need to write your own TPopupList descendant:
type
TPopupListEx = class(TPopupList)
protected
procedure WndProc(var Message: TMessage); override;
end;
{ TPopupListEx }
procedure TPopupListEx.WndProc(var Message: TMessage);
begin
if Message.Msg = WM_MENURBUTTONUP then
ShowMessage('rbu')
else
inherited
end;
initialization
FreeAndNil(PopupList);
PopupList := TPopupListEx.Create;
And make sure to set the TPopupMenu's TrackButton to tbLeftButton.
If you have several popup menus, you might try something like this (not fully tested):
procedure TPopupListEx.WndProc(var Message: TMessage);
begin
if Message.Msg = WM_MENURBUTTONUP then
begin
for var X in PopupList do
if TObject(X) is TPopupMenu then
begin
OutputDebugString(PChar(TPopupMenu(X).Name));
var MI: TMenuItem;
if TPopupMenu(X).Handle = HMENU(Message.LParam) then
MI := TPopupMenu(X).Items
else
MI := TPopupMenu(X).FindItem(HMENU(Message.LParam), fkHandle);
if Assigned(MI) and InRange(Message.WParam, 0, MI.Count - 1) then
begin
ShowMessageFmt('Menu item "%s" right clicked.', [MI.Items[Message.WParam].Caption]);
Break;
end;
end;
end
else
inherited
end;
I have a panel with a few TRadioButtons placed horizontally. If the most left button is focused and I press Left Arrow, the focus jumps to the most right button. I want to stop this behavoir for all arrows when they reach the edge. Is it possible ?
I tried overriding the WM_KEYDOWN but the buttons never receive this message when a arrow key is pressed.
TRadioButton = class(StdCtrls.TRadioButton)
protected
procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
procedure WMKeyUp(var Message: TWMKeyUp); message WM_KEYUP;
public
BlockLeft, BlockRight: Boolean;
constructor Create(AOwner: TComponent); override;
end;
constructor TRadioButton.Create(AOwner: TComponent);
begin
inherited;
BlockLeft:= False;
BlockRight:= False;
end;
procedure TRadioButton.WMKeyDown(var Message: TWMKeyDown);
begin
if BlockLeft and (Message.CharCode = VK_LEFT) then Exit;
if BlockRight and (Message.CharCode = VK_RIGHT) then Exit;
inherited;
end;
procedure TRadioButton.WMKeyUp(var Message: TWMKeyUp);
begin
if BlockLeft and (Message.CharCode = VK_LEFT) then Exit;
if BlockRight and (Message.CharCode = VK_RIGHT) then Exit;
inherited;
end;
VCL offsets keyboard messages to become a control notification and sends it to the message's destined control. Hence you should be intercepting a CN_KEYDOWN message instead.
If this is for a one time design consideration, I would prefer to handle this behavior at the form level since IMO a control, itself, shouldn't care where it is placed on. For a form where all radio buttons are expected to behave similar, an example could be:
procedure TForm1.CMDialogKey(var Message: TCMDialogKey);
begin
if ActiveControl is TRadioButton then
case Message.CharCode of
VK_LEFT, VK_UP: begin
if ActiveControl.Parent.Controls[0] = ActiveControl then begin
Message.Result := 1;
Exit;
end;
end;
VK_RIGHT, VK_DOWN: begin
if ActiveControl.Parent.Controls[ActiveControl.Parent.ControlCount - 1]
= ActiveControl then begin
Message.Result := 1;
Exit;
end;
end;
end;
inherited;
end;
If this is not for a one time behavior, I'd go for writing a container control as Victoria mentioned in the comments to the question.
I have a VCL form that is set for bsDialog with biHelp enabled ("?" icon in application bar). The application is also using a custom VCL Style (Aqua Light Slate).
However I cannot get the WMNCLBUTTONDOWN Windows Message to appear when I click the "?" button. It only works if the VCL Style of the application is changed back to Windows (Default).
procedure TMainFrm.WMNCLButtonDown(var Msg: TWMNCLButtonDown);
begin
if Msg.HitTest = HTHELP then
begin
OutputDebugString('Help button down');
Msg.Result := 0;
end
else
inherited;
end;
procedure TMainFrm.WMNCLButtonUp(var Msg: TWMNCLButtonUp);
begin
if Msg.HitTest = HTHELP then
begin
OutputDebugString('Help button up');
Msg.Result := 0;
end
else
inherited;
end;
Is there a way to get these events to fire with a custom VCL style?
The form style hook handles that message:
TFormStyleHook = class(TMouseTrackControlStyleHook)
....
procedure WMNCLButtonUp(var Message: TWMNCHitMessage); message WM_NCLBUTTONUP;
end;
The implementation includes this
else if (Message.HitTest = HTHELP) and (biHelp in Form.BorderIcons) then
Help;
This calls the virtual Help method of the form style hook. That is implemented like this:
procedure TFormStyleHook.Help;
begin
SendMessage(Handle, WM_SYSCOMMAND, SC_CONTEXTHELP, 0)
end;
So you could simply listen for WM_SYSCOMMAND and test wParam for SC_CONTEXTHELP. Like this:
type
TMainFrm = class(TForm)
protected
procedure WMSysCommand(var Message: TWMSysCommand); message WM_SYSCOMMAND;
end;
....
procedure TMainFrm.WMSysCommand(var Message: TWMSysCommand);
begin
if Message.CmdType = SC_CONTEXTHELP then begin
OutputDebugString('Help requested');
Message.Result := 0;
end else begin
inherited;
end;
end;
I'm trying to make app to show some information, It'll create Panels runtime and place info on it, each panel will be flat as on picture, also app will use runtime themes, so i'd not be able to change panel bg color on mouse move, I tried to place info on TSpeedButton :v O.o it has wonderfull highlight function when it's flat while app is using runtime theme, but the main problem is that images and labels aren't moving when i move speedbutton and i need this much, they just stay there..
I tried to edit TCustomPanel.Paint to see if panel will look like highlighted button, adding code at the end:
PaintRect := ClientRect;
Details := StyleServices.GetElementDetails(ttbButtonHot);
StyleServices.DrawElement(Canvas.Handle, Details, PaintRect);
but with no success..
also it's pretty hard to link some custom code OnClick event at runtime, e.g:
ShowMessage('custom message on each panel');
I have not got any idea on how to do this, hope some one will give me advice or show me some example..
btw, panel will be created this way:
var
P: TPanel;
begin
P := TPanel.Create(Self);
P.Left := 20;
P.Top := 100;
P.Width := 60;
P.Height := 20;
P.Visible := True;
P.Parent := Self;
#P.OnClick := #Showmessageproc; // somehow this way..
end;
App pic:
If i do so:
procedure TMyPanel.MouseMove(Shift: TShiftState; X, Y: Integer);
var
mEvnt: TTrackMouseEvent;
begin
inherited;
if not FMouseTracking then begin
mEvnt.cbSize := SizeOf(mEvnt);
mEvnt.dwFlags := TME_LEAVE;
mEvnt.hwndTrack := Handle;
TrackMouseEvent(mEvnt);
FMouseTracking := True;
showmessage('IN');
end;
end;
procedure TMyPanel.WMMouseLeave(var Msg: TMessage);
begin
if Msg.Msg = WM_MOUSELEAVE then showmessage('OUT');
Msg.Result := 0;
FMouseTracking := False;
if Assigned(FOnMouseLeave) then
FOnMouseLeave(Self);
end;
procedure G(Sender: TObject);
begin
showmessage('message');
end;
procedure TMainFrm.Button1Click(Sender: TObject);
var
P: TMyPanel;
begin
P := TMyPanel.Create(Self);
P.Left := 20;
I := I + 100;
P.Top := I;
P.Width := 200;
P.Height := 80;
P.Visible := True;
P.Parent := Self;
#P.OnClick := #g;
end;
when I move mouse on runtime created panel, 2 msgbox appears, IN and OUT, "mousemove" works fine but "mouse leave" bad, also the mainc question is still actual. the problem is that that I can't get canvas of created panel to draw on. the example above could be achieved more simple way:
#P.OnMouseLeave := #onmouseleaveproc;
#P.OnMouseMove := #onmousemoveproc;
but with Canvas, everything is more difficult, somewhere i've read that canvas is protected in TCustomPanel.
Also there's another question: Is it possible to handle panel wich called e.g OnMouseMove ? because there maybe will be 30 of them (runtime created panels)
I've tried this way: (and it does not works)
type
TMyPanel = class(TPanel)
public
constructor Create(AOwner: TComponent); override;
private
// FMouseTracking: Boolean;
// FOnMouseLeave: TNotifyEvent;
procedure CMMouseEnter(var msg: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var msg: TMessage); message CM_MOUSELEAVE;
protected
// procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
published
// property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
end;
constructor TMyPanel.Create(AOwner: TComponent);
begin
ControlStyle := ControlStyle - [csParentBackground] + [csOpaque];
inherited;
end;
procedure TMyPanel.CMMouseEnter(var msg: TMessage);
begin
inherited;
Color := clBlue;
{ Do Whatever }
end;
procedure TMyPanel.CMMouseLeave(var msg: TMessage);
begin
inherited;
Color := clRed;
{ Do Whatever }
end;
Simply, color does not changes. (color changes with themes OFF)
It's basically explained here for Delphi 6, but same concept I think. You want to define a custom windows message handler for your panel. This will give you basic mouse enter/exit capability. You can then play with setting TPanel properties from there to find something to your liking. For example, to mock a speed button, you might be able to just set the background color and change the border bevel accordingly. If that isn't adequate, you can write to the TPanel's Canvas directly (paint the behavior that you want to see) on mouse enter/exit to get the visual behavior you're after.
I created the following new component in Delphi and installed it. A new TColorPanel component showed up in a new MyComponents tab in the IDE. I then used this to put a TColorPanel on a new app and it responded properly to the mouse enter/leave events, changing the color as desired. I'm not sure how you made your app's panels as TMyPanel instead of standard TPanel. This is just how I tried it. I used your latest message handling code as-is.
unit ColorPanel;
interface
uses
WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls;
type
TColorPanel = class(TPanel)
public
constructor Create(AOwner: TComponent); override;
private
procedure CMMouseEnter(var msg: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var msg: TMessage); message CM_MOUSELEAVE;
protected
// procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
published
// property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('MyComponents', [TColorPanel]);
end;
constructor TColorPanel.Create(AOwner: TComponent);
begin
ControlStyle := ControlStyle - [csParentBackground] + [csOpaque];
inherited;
end;
procedure TColorPanel.CMMouseEnter(var msg: TMessage);
begin
inherited;
Color := clBlue;
{ Do Whatever }
end;
procedure TColorPanel.CMMouseLeave(var msg: TMessage);
begin
inherited;
Color := clRed;
{ Do Whatever }
end;
end.
I'm not sure why yours isn't working, other than to determine how you declared your app's panels to be TMyPanel.
Good evening :-)!
I have this code to use Drag & Drop method for files:
TForm1 = class(TForm)
...
public
procedure DropFiles(var msg: TMessage ); message WM_DROPFILES;
end;
procedure TForm1.FormCreate(Sender: TObject)
begin
DragAcceptFiles(ListView1.Handle, True);
end;
procedure TForm1.DropFiles(var msg: TMessage );
var
i, count : integer;
dropFileName : array [0..511] of Char;
MAXFILENAME: integer;
begin
MAXFILENAME := 511;
count := DragQueryFile(msg.WParam, $FFFFFFFF, dropFileName, MAXFILENAME);
for i := 0 to count - 1 do
begin
DragQueryFile(msg.WParam, i, dropFileName, MAXFILENAME);
Memo1.Lines.Add(dropFileName);
end;
DragFinish(msg.WParam);
end;
In area of ListView is DragCursor, but in Memo1 aren't any records.
When I use for example ListBox and method DragAcceptFiles(ListBox1.Handle, True) ever is fine.
ListView property DragMode I set to dmAutomatic.
Thanks :-)
You've called DragAcceptFiles for the ListView, so Windows sends the WM_DROPFILES to your ListView and not to your Form. You have to catch the WM_DROPFILES message from the ListView.
private
FOrgListViewWndProc: TWndMethod;
procedure ListViewWndProc(var Msg: TMessage);
// ...
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
// Redirect the ListView's WindowProc to ListViewWndProc
FOrgListViewWndProc := ListView1.WindowProc;
ListView1.WindowProc := ListViewWndProc;
DragAcceptFiles(ListView1.Handle, True);
end;
procedure TForm1.ListViewWndProc(var Msg: TMessage);
begin
// Catch the WM_DROPFILES message, and call the original ListView WindowProc
// for all other messages.
case Msg.Msg of
WM_DROPFILES:
DropFiles(Msg);
else
if Assigned(FOrgListViewWndProc) then
FOrgListViewWndProc(Msg);
end;
end;
Your problem is, you're registering the list view window as a drop target, but handling the WM_DROPFILES message in the form class. The message is sent to the list view control, you should handle the message there.