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.
Related
I'm writing a custom control which is simply a container with a non-client area. Within that non-client area, there's one small area which is a button, and the rest of it is transparent. The drawing isn't an exact rectangle.
So far, I have it half-way working. The problem is that it doesn't calculate the non-client area up front, unless I make a minor tweak, such as re-sizing it.
I've followed many resources describing how to accomplish this. My implementation of handling WM_NCCALCSIZE is more or less identical to "working" examples I've found. But when the control is first created, it does not calculate this at all. When I drop a breakpoint inside the message handler of mine (WMNCCalcSize), based on the examples I've found, I'm supposed to first check Msg.CalcValidRects, and only do my calculation if it's True. But when debugging run-time, it's False, thus the calculation isn't done.
In design-time, if I re-size the control, THEN it decides to calculate properly. It's still not perfect (this code is still in the works), but it doesn't seem to set the non-client area until after I tweak it. Further, in run-time, if I tweak the size in the code, it still doesn't calculate.
The image on the top is when the form is initially created/shown. The second one is after I re-size it a little bit. Notice the test button, which is aligned alLeft. So initially, it consumes the area which is supposed to be non-client.
If I comment out the check if Msg.CalcValidRects then begin, then it calculates properly. But I see every example doing this check, and I'm pretty sure it's needed.
What am I doing wrong and how to make it calculate the non-client area at all times?
unit FloatBar;
interface
uses
System.Classes, System.SysUtils, System.Types,
Vcl.Controls, Vcl.Graphics, Vcl.Forms,
Winapi.Windows, Winapi.Messages;
type
TFloatBar = class(TCustomControl)
private
FCollapsed: Boolean;
FBtnHeight: Integer;
FBtnWidth: Integer;
procedure RepaintBorder;
procedure PaintBorder;
procedure SetCollapsed(const Value: Boolean);
function BtnRect: TRect;
procedure SetBtnHeight(const Value: Integer);
procedure SetBtnWidth(const Value: Integer);
function TransRect: TRect;
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT;
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
procedure WMNCCalcSize(var Msg: TWMNCCalcSize); message WM_NCCALCSIZE;
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Repaint; override;
procedure Invalidate; override;
published
property BtnWidth: Integer read FBtnWidth write SetBtnWidth;
property BtnHeight: Integer read FBtnHeight write SetBtnHeight;
property Collapsed: Boolean read FCollapsed write SetCollapsed;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Float Bar', [TFloatBar]);
end;
{ TFloatBar }
constructor TFloatBar.Create(AOwner: TComponent);
begin
inherited;
ControlStyle:= [csAcceptsControls,
csCaptureMouse,
csDesignInteractive,
csClickEvents,
csReplicatable,
csNoStdEvents
];
Width:= 400;
Height:= 60;
FBtnWidth:= 50;
FBtnHeight:= 20;
FCollapsed:= False;
end;
procedure TFloatBar.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params.WindowClass do
Style := Style and not (CS_HREDRAW or CS_VREDRAW);
end;
destructor TFloatBar.Destroy;
begin
inherited;
end;
procedure TFloatBar.Invalidate;
begin
inherited;
RepaintBorder;
end;
procedure TFloatBar.Repaint;
begin
inherited Repaint;
RepaintBorder;
end;
procedure TFloatBar.RepaintBorder;
begin
if Visible and HandleAllocated then
Perform(WM_NCPAINT, 0, 0);
end;
procedure TFloatBar.SetBtnHeight(const Value: Integer);
begin
FBtnHeight := Value;
Invalidate;
end;
procedure TFloatBar.SetBtnWidth(const Value: Integer);
begin
FBtnWidth := Value;
Invalidate;
end;
procedure TFloatBar.SetCollapsed(const Value: Boolean);
begin
FCollapsed := Value;
Invalidate;
end;
procedure TFloatBar.WMNCPaint(var Message: TWMNCPaint);
begin
inherited;
PaintBorder;
end;
procedure TFloatBar.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
procedure TFloatBar.WMNCCalcSize(var Msg: TWMNCCalcSize);
var
lpncsp: PNCCalcSizeParams;
begin
if Msg.CalcValidRects then begin //<------ HERE --------
lpncsp := Msg.CalcSize_Params;
if lpncsp = nil then Exit;
lpncsp.rgrc[0].Bottom:= lpncsp.rgrc[0].Bottom-FBtnHeight;
Msg.Result := 0;
end;
inherited;
end;
function TFloatBar.BtnRect: TRect;
begin
//Return a rect where the non-client collapse button is to be...
Result:= Rect(ClientWidth-FBtnWidth, ClientHeight, ClientWidth, ClientHeight+FBtnHeight);
end;
function TFloatBar.TransRect: TRect;
begin
//Return a rect where the non-client transparent area is to be...
Result:= Rect(0, ClientHeight, ClientWidth, ClientHeight+FBtnHeight);
end;
procedure TFloatBar.WMNCHitTest(var Message: TWMNCHitTest);
var
P: TPoint;
C: TCursor;
begin
C:= crDefault; //TODO: Find a way to change cursor elsewhere...
P:= Point(Message.XPos, Message.YPos);
if PtInRect(BtnRect, P) then begin
Message.Result:= HTCLIENT;
C:= crHandPoint;
end else
if PtInRect(TransRect, P) then
Message.Result:= HTTRANSPARENT
else
inherited;
Screen.Cursor:= C;
end;
procedure TFloatBar.Paint;
begin
inherited;
//Paint Background
Canvas.Brush.Style:= bsSolid;
Canvas.Pen.Style:= psClear;
Canvas.Brush.Color:= Color;
Canvas.FillRect(Canvas.ClipRect);
Canvas.Pen.Style:= psSolid;
Canvas.Pen.Width:= 3;
Canvas.Brush.Style:= bsClear;
Canvas.Pen.Color:= clBlue;
Canvas.MoveTo(0, 0);
Canvas.LineTo(ClientWidth, 0); //Top
Canvas.LineTo(ClientWidth, ClientHeight+FBtnHeight); //Right
Canvas.LineTo(ClientWidth-FBtnWidth, ClientHeight+FBtnHeight); //Bottom of Button
Canvas.LineTo(ClientWidth-FBtnWidth, ClientHeight); //Left of Button
Canvas.LineTo(0, ClientHeight); //Bottom
Canvas.LineTo(0, 0);
end;
procedure TFloatBar.PaintBorder;
begin
Canvas.Handle:= GetWindowDC(Handle);
try
//TODO: Paint "transparent" area by painting parent...
//Paint NC button background
Canvas.Brush.Style:= bsSolid;
Canvas.Pen.Style:= psClear;
Canvas.Brush.Color:= Color;
Canvas.Rectangle(ClientWidth-FBtnWidth, ClientHeight, ClientWidth, ClientHeight+FBtnHeight);
//Paint NC button border
Canvas.Pen.Style:= psSolid;
Canvas.Pen.Width:= 3;
Canvas.Brush.Style:= bsClear;
Canvas.Pen.Color:= clBlue;
Canvas.MoveTo(ClientWidth, ClientHeight);
Canvas.LineTo(ClientWidth, ClientHeight+FBtnHeight);
Canvas.LineTo(ClientWidth-FBtnWidth, ClientHeight+FBtnHeight);
Canvas.LineTo(ClientWidth-FBtnWidth, ClientHeight);
//Paint NC Button Chevron //TODO: Calculate chevron size/position
if FCollapsed then begin
Canvas.MoveTo(ClientWidth-30, ClientHeight+7);
Canvas.LineTo(ClientWidth-25, ClientHeight+13);
Canvas.LineTo(ClientWidth-20, ClientHeight+7);
end else begin
Canvas.MoveTo(ClientWidth-30, ClientHeight+13);
Canvas.LineTo(ClientWidth-25, ClientHeight+7);
Canvas.LineTo(ClientWidth-20, ClientHeight+13);
end;
finally
ReleaseDC(Handle, Canvas.Handle);
end;
end;
end.
... I'm supposed to first check Msg.CalcValidRects, and only do my
calculation if it's True.
You've got that wrong. The message has a somewhat complicated mechanism and the documentation might be slightly confusing trying to explain two distinct mode the message operates (wParam true or false). The part that relates to your case is the second paragraph of lParam:
If wParam is FALSE, lParam points to a RECT structure. On entry, the
structure contains the proposed window rectangle for the window. On
exit, the structure should contain the screen coordinates of the
corresponding window client area.
You'll find numerous usage examples of this simple form in the VCL where wParam is not checked at all, like in TToolWindow.WMNCCalcSize, TCustomCategoryPanel.WMNCCalcSize etc..
(Note that NCCALCSIZE_PARAMS.rgrc is not even a rectangle array when wParam is false, but since you're operating on the supposed first rectangle, you're fine.)
By Long Press, I mean pressing a button / panel and hold for a period (say 2 seconds) without releasing or dragging around. It is common in mobile phone and touch device.
I had tried using Gesture, checked toPressAndHold in TabletOptions and Checked all in InteractiveGestureOptions but long pressing cause no OnGesture Call.
Another implementation I can think of is adding a timer, start it in MouseDown and end it in either Timer Fired, StartDrag, MouseUp or MouseLeave. However, as I want to add this behavior to several different buttons and panel component, I would have to override a brunch of procedure in each class and copy the code around for each component.
Is there a better way of achieving that?
Edit :
To NGLN
Woo, great piece of work! Together with your answer to those scrolling effects, VCL can almost achieve mobile OS look and feel!
Your code work perfectly with common controls but I got 2 issues in my case
Long Clicking on the form cannot be detected (of cause as the form
is not parent of itself) I shift the Find FChild Code to separate
procedure and call from both WMParentNotify and FormMouseDown to
solve it.
I got some custom button which has some disabled HTML
labels (Header, Caption, Footer) covering up the label original
surface, Using your code, FChild will be one of those label but it
do not get MouseCapture. I add the below line to overcome it :
while not TControlAccess(FChild).Enabled do
FChild := FChild.Parent;
Finally, for some more complicated controls like TCategoryButtons or TListBox, the user of the event might need to check not against the whole control but a specify item in the control. So I think we need to save the original CursorPos and fire another event when the timer triggered to let manual determination of whether it meet the long press condition or not. If yes or event not assigned, then use your default code for determination.
All in all, we can just create a LongPress supported form / panel to host all other controls. This is much more easier then implementing the LongPress feature Component by Component! Great Thanks!
Edit2 :
To NGLN
Thanks again for your component version, which is excellent approach, not needing to do any modification to existing components and can detect long press everywhere!
For your information, I had do several modification to suit my own need.
TCustomForm vs TWinControl : As most of my application has only 1 main form and all other visual units are my own created frame (not from TFrame but TScrollingWinControl with ccpack support), assuming TCustomForm do not work for me. So I had deleted property form (but retain FForm for ActiveControl) and create a published property Host : TWinControl to act as the parent host. In that way, I can also limit the detection to some limited panel. When Assigning Host, I check and find the FForm using GetParentForm(FHost).
Disabled Controls : As I said previously, I got some disabled TJvHTLabel covering my buttons and your component work on the labels. I can of cause find back the button by the label, but I think it would be more convenient if it had been handled by the new component. So I add a property SkipDisabled and if set to turn, loop in its parent line to find first enabled control.
I add a PreserveFocus property to let component user choose to keep last activecontrol or not.
Controls with items. I changed your TLongPressEvent, adding the ClickPos as the 2nd parameter. So, I can now use the ClickPos to find which item in a list box or the like had been long held.
It seems to me that FindVCLWindow is having same effect with your FindControlAtPos?
Thank you again for your great work.
At every left mouse button click, WM_PARENTNOTIFY is send to all (grand) parents of the clicked control. So this can be used for tracking the starting point of a long press, and the duration of a press can be timed with a timer. What is left is to decide when a press should be called a long press. And to wrap this all up in a nice component of course.
In the component written below, the OnLongPress event handler is fired when the following conditions are met:
after the interval, the control still has mouse capture, or still has focus, or is disabled,
after the interval, the mouse has not moved more then Mouse.DragThreshold.
Some explanation on the code:
It temporarily replaces the control's OnMouseUp event handler, otherwise consecutive clicks might also result in a long press. The intermediate event handler disables the tracking timer, calls the original event handler and replaces it back.
After the long press, the active control is reset, because I thought a long press is not done with the intention to focus the control. But that's just my guess, and it might be candidate for a property.
Also tracks for long presses on the form itself (rather then only its childs).
Has a customized FindControlAtPos routine which performs a deep search on an arbitrary window. Alternatives were (1) TWinControl.ControlAtPos, but it searches just one level deep, and (2) Controls.FindDragTarget, but despite the AllowDisabled parameter, it is not able of finding disabled controls.
unit LongPressEvent;
interface
uses
Classes, Controls, Messages, Windows, Forms, ExtCtrls;
type
TLongPressEvent = procedure(Control: TControl) of object;
TLongPressTracker = class(TComponent)
private
FChild: TControl;
FClickPos: TPoint;
FForm: TCustomForm;
FOldChildOnMouseUp: TMouseEvent;
FOldFormWndProc: TFarProc;
FOnLongPress: TLongPressEvent;
FPrevActiveControl: TWinControl;
FTimer: TTimer;
procedure AttachForm;
procedure DetachForm;
function GetDuration: Cardinal;
procedure LongPressed(Sender: TObject);
procedure NewChildMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure NewFormWndProc(var Message: TMessage);
procedure SetDuration(Value: Cardinal);
procedure SetForm(Value: TCustomForm);
procedure StartTracking;
protected
procedure Notification(AComponent: TComponent; Operation: TOperation);
override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Form: TCustomForm read FForm write SetForm;
published
property Duration: Cardinal read GetDuration write SetDuration
default 1000;
property OnLongPress: TLongPressEvent read FOnLongPress
write FOnLongPress;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TLongPressTracker]);
end;
function FindControlAtPos(Window: TWinControl;
const ScreenPos: TPoint): TControl;
var
I: Integer;
C: TControl;
begin
for I := Window.ControlCount - 1 downto 0 do
begin
C := Window.Controls[I];
if C.Visible and PtInRect(C.ClientRect, C.ScreenToClient(ScreenPos)) then
begin
if C is TWinControl then
Result := FindControlAtPos(TWinControl(C), ScreenPos)
else
Result := C;
Exit;
end;
end;
Result := Window;
end;
{ TLongPressTracker }
type
TControlAccess = class(TControl);
procedure TLongPressTracker.AttachForm;
begin
if FForm <> nil then
begin
FForm.HandleNeeded;
FOldFormWndProc := Pointer(GetWindowLong(FForm.Handle, GWL_WNDPROC));
SetWindowLong(FForm.Handle, GWL_WNDPROC,
Integer(MakeObjectInstance(NewFormWndProc)));
end;
end;
constructor TLongPressTracker.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FTimer := TTimer.Create(Self);
FTimer.Enabled := False;
FTimer.Interval := 1000;
FTimer.OnTimer := LongPressed;
if AOwner is TCustomForm then
SetForm(TCustomForm(AOwner));
end;
destructor TLongPressTracker.Destroy;
begin
if FTimer.Enabled then
begin
FTimer.Enabled := False;
TControlAccess(FChild).OnMouseUp := FOldChildOnMouseUp;
end;
DetachForm;
inherited Destroy;
end;
procedure TLongPressTracker.DetachForm;
begin
if FForm <> nil then
begin
if FForm.HandleAllocated then
SetWindowLong(FForm.Handle, GWL_WNDPROC, Integer(FOldFormWndProc));
FForm := nil;
end;
end;
function TLongPressTracker.GetDuration: Cardinal;
begin
Result := FTimer.Interval;
end;
procedure TLongPressTracker.LongPressed(Sender: TObject);
begin
FTimer.Enabled := False;
if (Abs(FClickPos.X - Mouse.CursorPos.X) < Mouse.DragThreshold) and
(Abs(FClickPos.Y - Mouse.CursorPos.Y) < Mouse.DragThreshold) and
(((FChild is TWinControl) and TWinControl(FChild).Focused) or
(TControlAccess(FChild).MouseCapture or (not FChild.Enabled))) then
begin
FForm.ActiveControl := FPrevActiveControl;
if Assigned(FOnLongPress) then
FOnLongPress(FChild);
end;
TControlAccess(FChild).OnMouseUp := FOldChildOnMouseUp;
end;
procedure TLongPressTracker.NewChildMouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
FTimer.Enabled := False;
if Assigned(FOldChildOnMouseUp) then
FOldChildOnMouseUp(Sender, Button, Shift, X, Y);
TControlAccess(FChild).OnMouseUp := FOldChildOnMouseUp;
end;
procedure TLongPressTracker.NewFormWndProc(var Message: TMessage);
begin
case Message.Msg of
WM_PARENTNOTIFY:
if TWMParentNotify(Message).Event = WM_LBUTTONDOWN then
StartTracking;
WM_LBUTTONDOWN:
StartTracking;
end;
with Message do
Result := CallWindowProc(FOldFormWndProc, FForm.Handle, Msg, WParam,
LParam);
end;
procedure TLongPressTracker.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (AComponent = FForm) and (Operation = opRemove) then
DetachForm;
if (AComponent = FChild) and (Operation = opRemove) then
begin
FTimer.Enabled := False;
FChild := nil;
end;
end;
procedure TLongPressTracker.SetDuration(Value: Cardinal);
begin
FTimer.Interval := Value;
end;
procedure TLongPressTracker.SetForm(Value: TCustomForm);
begin
if FForm <> Value then
begin
DetachForm;
FForm := Value;
FForm.FreeNotification(Self);
AttachForm;
end;
end;
procedure TLongPressTracker.StartTracking;
begin
FClickPos := Mouse.CursorPos;
FChild := FindControlAtPos(FForm, FClickPos);
FChild.FreeNotification(Self);
FPrevActiveControl := FForm.ActiveControl;
FOldChildOnMouseUp := TControlAccess(FChild).OnMouseUp;
TControlAccess(FChild).OnMouseUp := NewChildMouseUp;
FTimer.Enabled := True;
end;
end.
To get this component working, add it to a package, or use this runtime code:
...
private
procedure LongPress(Control: TControl);
end;
...
procedure TForm1.FormCreate(Sender: TObject);
begin
with TLongPressTracker.Create(Self) do
OnLongPress := LongPress;
end;
procedure TForm1.LongPress(Control: TControl);
begin
Caption := 'Long press occurred on: ' + Sender.ClassName;
end;
While a user is re-sizing a form, in XE2 I would like to display the current form size alongside the current mouse cursor. I would use the OnResize event.
In other words: I need ideas on how to display dynamic text (e.g. x,y coordinates like the 300, 250 in the image below) along with the mouse cursor as a user moves their mouse.
One approach would be to mock up a .cur file and assign it to the cursor in OnResize. That seems cumbersome and might be quite slow (and I have no idea yet of the file's contents)
Another idea would be to display some transparent text (what component would do that?) that I set .Top, .Left in the OnResize event.
One concern I have is how I would detect when the re-sizing operation is complete so I could revert to the standard mouse cursor.
Any suggestions a direction to proceed?
Update:
Here is an updated version, where was removed the hint animation part (since I feel you need to display the hint immediately for your purpose) and where was added double buffering (due to frequent updates of the hint) to prevent flickering and also a decent alpha blending (just for curiosity).
Thanks to #NGLN fixed a missing unassigning of a hint window variable!
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TAlphaHintWindow = class(THintWindow)
private
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWindowHandle(const Params: TCreateParams); override;
public
constructor Create(AOwner: TComponent); override;
procedure ActivateHint(Rect: TRect; const AHint: string); override;
end;
type
TForm1 = class(TForm)
private
FSizeMove: Boolean;
FHintWindow: TAlphaHintWindow;
procedure WMEnterSizeMove(var AMessage: TMessage); message WM_ENTERSIZEMOVE;
procedure WMSize(var AMessage: TWMSize); message WM_SIZE;
procedure WMExitSizeMove(var AMessage: TMessage); message WM_EXITSIZEMOVE;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TAlphaHintWindow }
constructor TAlphaHintWindow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
// window might be updated quite frequently, so enable double buffer
DoubleBuffered := True;
end;
procedure TAlphaHintWindow.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
// include the layered window style (for alpha blending)
Params.ExStyle := Params.ExStyle or WS_EX_LAYERED;
end;
procedure TAlphaHintWindow.CreateWindowHandle(const Params: TCreateParams);
begin
inherited CreateWindowHandle(Params);
// value of 220 here is the alpha (the same as form's AlphaBlendValue)
SetLayeredWindowAttributes(Handle, ColorToRGB(clNone), 220, LWA_ALPHA);
end;
procedure TAlphaHintWindow.ActivateHint(Rect: TRect; const AHint: string);
var
Monitor: TMonitor;
begin
// from here was just stripped the animation part and fixed one bug
// (setting a hint window top position when going off screen; it is
// at least in Delphi 2009 with the most recent updates)
Caption := AHint;
Inc(Rect.Bottom, 4);
UpdateBoundsRect(Rect);
Monitor := Screen.MonitorFromPoint(Point(Rect.Left, Rect.Top));
if Width > Monitor.Width then
Width := Monitor.Width;
if Height > Monitor.Height then
Height := Monitor.Height;
if Rect.Top + Height > Monitor.Top + Monitor.Height then
Rect.Top := (Monitor.Top + Monitor.Height) - Height;
if Rect.Left + Width > Monitor.Left + Monitor.Width then
Rect.Left := (Monitor.Left + Monitor.Width) - Width;
if Rect.Left < Monitor.Left then
Rect.Left := Monitor.Left;
if Rect.Top < Monitor.Top then
Rect.Top := Monitor.Top;
ParentWindow := Application.Handle;
SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, Width, Height,
SWP_NOACTIVATE);
ShowWindow(Handle, SW_SHOWNOACTIVATE);
Invalidate;
end;
procedure TAlphaHintWindow.CMTextChanged(var Message: TMessage);
begin
// do exactly nothing, because we're adjusting the size by ourselves
// and the ancestor would just autosize the window by the text; text
// or if you want Caption, is updated only by calling ActivateHint
end;
{ TForm1 }
procedure TForm1.WMEnterSizeMove(var AMessage: TMessage);
begin
inherited;
FSizeMove := True;
end;
procedure TForm1.WMSize(var AMessage: TWMSize);
var
CurPos: TPoint;
begin
inherited;
if FSizeMove and GetCursorPos(CurPos) then
begin
if not Assigned(FHintWindow) then
FHintWindow := TAlphaHintWindow.Create(nil);
FHintWindow.ActivateHint(
Rect(CurPos.X + 20, CurPos.Y - 20, CurPos.X + 120, CurPos.Y + 30),
'Current size' + sLineBreak +
'Width: ' + IntToStr(Width) + sLineBreak +
'Height: ' + IntToStr(Height));
end;
end;
procedure TForm1.WMExitSizeMove(var AMessage: TMessage);
begin
inherited;
FHintWindow.Free;
FHintWindow := nil;
FSizeMove := False;
end;
end.
And the result at form sizing (quite a lot transparent to my taste :-)
Does it really need to be transparent? Keep in mind that text can be hard to read over certain backgrounds.
Instead, consider showing a tool-tip window. Create a THintWindow control, set its caption and position, and show it.
When you receive a wm_ExitSizeMove message, hide or destroy the window.
By Long Press, I mean pressing a button / panel and hold for a period (say 2 seconds) without releasing or dragging around. It is common in mobile phone and touch device.
I had tried using Gesture, checked toPressAndHold in TabletOptions and Checked all in InteractiveGestureOptions but long pressing cause no OnGesture Call.
Another implementation I can think of is adding a timer, start it in MouseDown and end it in either Timer Fired, StartDrag, MouseUp or MouseLeave. However, as I want to add this behavior to several different buttons and panel component, I would have to override a brunch of procedure in each class and copy the code around for each component.
Is there a better way of achieving that?
Edit :
To NGLN
Woo, great piece of work! Together with your answer to those scrolling effects, VCL can almost achieve mobile OS look and feel!
Your code work perfectly with common controls but I got 2 issues in my case
Long Clicking on the form cannot be detected (of cause as the form
is not parent of itself) I shift the Find FChild Code to separate
procedure and call from both WMParentNotify and FormMouseDown to
solve it.
I got some custom button which has some disabled HTML
labels (Header, Caption, Footer) covering up the label original
surface, Using your code, FChild will be one of those label but it
do not get MouseCapture. I add the below line to overcome it :
while not TControlAccess(FChild).Enabled do
FChild := FChild.Parent;
Finally, for some more complicated controls like TCategoryButtons or TListBox, the user of the event might need to check not against the whole control but a specify item in the control. So I think we need to save the original CursorPos and fire another event when the timer triggered to let manual determination of whether it meet the long press condition or not. If yes or event not assigned, then use your default code for determination.
All in all, we can just create a LongPress supported form / panel to host all other controls. This is much more easier then implementing the LongPress feature Component by Component! Great Thanks!
Edit2 :
To NGLN
Thanks again for your component version, which is excellent approach, not needing to do any modification to existing components and can detect long press everywhere!
For your information, I had do several modification to suit my own need.
TCustomForm vs TWinControl : As most of my application has only 1 main form and all other visual units are my own created frame (not from TFrame but TScrollingWinControl with ccpack support), assuming TCustomForm do not work for me. So I had deleted property form (but retain FForm for ActiveControl) and create a published property Host : TWinControl to act as the parent host. In that way, I can also limit the detection to some limited panel. When Assigning Host, I check and find the FForm using GetParentForm(FHost).
Disabled Controls : As I said previously, I got some disabled TJvHTLabel covering my buttons and your component work on the labels. I can of cause find back the button by the label, but I think it would be more convenient if it had been handled by the new component. So I add a property SkipDisabled and if set to turn, loop in its parent line to find first enabled control.
I add a PreserveFocus property to let component user choose to keep last activecontrol or not.
Controls with items. I changed your TLongPressEvent, adding the ClickPos as the 2nd parameter. So, I can now use the ClickPos to find which item in a list box or the like had been long held.
It seems to me that FindVCLWindow is having same effect with your FindControlAtPos?
Thank you again for your great work.
At every left mouse button click, WM_PARENTNOTIFY is send to all (grand) parents of the clicked control. So this can be used for tracking the starting point of a long press, and the duration of a press can be timed with a timer. What is left is to decide when a press should be called a long press. And to wrap this all up in a nice component of course.
In the component written below, the OnLongPress event handler is fired when the following conditions are met:
after the interval, the control still has mouse capture, or still has focus, or is disabled,
after the interval, the mouse has not moved more then Mouse.DragThreshold.
Some explanation on the code:
It temporarily replaces the control's OnMouseUp event handler, otherwise consecutive clicks might also result in a long press. The intermediate event handler disables the tracking timer, calls the original event handler and replaces it back.
After the long press, the active control is reset, because I thought a long press is not done with the intention to focus the control. But that's just my guess, and it might be candidate for a property.
Also tracks for long presses on the form itself (rather then only its childs).
Has a customized FindControlAtPos routine which performs a deep search on an arbitrary window. Alternatives were (1) TWinControl.ControlAtPos, but it searches just one level deep, and (2) Controls.FindDragTarget, but despite the AllowDisabled parameter, it is not able of finding disabled controls.
unit LongPressEvent;
interface
uses
Classes, Controls, Messages, Windows, Forms, ExtCtrls;
type
TLongPressEvent = procedure(Control: TControl) of object;
TLongPressTracker = class(TComponent)
private
FChild: TControl;
FClickPos: TPoint;
FForm: TCustomForm;
FOldChildOnMouseUp: TMouseEvent;
FOldFormWndProc: TFarProc;
FOnLongPress: TLongPressEvent;
FPrevActiveControl: TWinControl;
FTimer: TTimer;
procedure AttachForm;
procedure DetachForm;
function GetDuration: Cardinal;
procedure LongPressed(Sender: TObject);
procedure NewChildMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure NewFormWndProc(var Message: TMessage);
procedure SetDuration(Value: Cardinal);
procedure SetForm(Value: TCustomForm);
procedure StartTracking;
protected
procedure Notification(AComponent: TComponent; Operation: TOperation);
override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Form: TCustomForm read FForm write SetForm;
published
property Duration: Cardinal read GetDuration write SetDuration
default 1000;
property OnLongPress: TLongPressEvent read FOnLongPress
write FOnLongPress;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TLongPressTracker]);
end;
function FindControlAtPos(Window: TWinControl;
const ScreenPos: TPoint): TControl;
var
I: Integer;
C: TControl;
begin
for I := Window.ControlCount - 1 downto 0 do
begin
C := Window.Controls[I];
if C.Visible and PtInRect(C.ClientRect, C.ScreenToClient(ScreenPos)) then
begin
if C is TWinControl then
Result := FindControlAtPos(TWinControl(C), ScreenPos)
else
Result := C;
Exit;
end;
end;
Result := Window;
end;
{ TLongPressTracker }
type
TControlAccess = class(TControl);
procedure TLongPressTracker.AttachForm;
begin
if FForm <> nil then
begin
FForm.HandleNeeded;
FOldFormWndProc := Pointer(GetWindowLong(FForm.Handle, GWL_WNDPROC));
SetWindowLong(FForm.Handle, GWL_WNDPROC,
Integer(MakeObjectInstance(NewFormWndProc)));
end;
end;
constructor TLongPressTracker.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FTimer := TTimer.Create(Self);
FTimer.Enabled := False;
FTimer.Interval := 1000;
FTimer.OnTimer := LongPressed;
if AOwner is TCustomForm then
SetForm(TCustomForm(AOwner));
end;
destructor TLongPressTracker.Destroy;
begin
if FTimer.Enabled then
begin
FTimer.Enabled := False;
TControlAccess(FChild).OnMouseUp := FOldChildOnMouseUp;
end;
DetachForm;
inherited Destroy;
end;
procedure TLongPressTracker.DetachForm;
begin
if FForm <> nil then
begin
if FForm.HandleAllocated then
SetWindowLong(FForm.Handle, GWL_WNDPROC, Integer(FOldFormWndProc));
FForm := nil;
end;
end;
function TLongPressTracker.GetDuration: Cardinal;
begin
Result := FTimer.Interval;
end;
procedure TLongPressTracker.LongPressed(Sender: TObject);
begin
FTimer.Enabled := False;
if (Abs(FClickPos.X - Mouse.CursorPos.X) < Mouse.DragThreshold) and
(Abs(FClickPos.Y - Mouse.CursorPos.Y) < Mouse.DragThreshold) and
(((FChild is TWinControl) and TWinControl(FChild).Focused) or
(TControlAccess(FChild).MouseCapture or (not FChild.Enabled))) then
begin
FForm.ActiveControl := FPrevActiveControl;
if Assigned(FOnLongPress) then
FOnLongPress(FChild);
end;
TControlAccess(FChild).OnMouseUp := FOldChildOnMouseUp;
end;
procedure TLongPressTracker.NewChildMouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
FTimer.Enabled := False;
if Assigned(FOldChildOnMouseUp) then
FOldChildOnMouseUp(Sender, Button, Shift, X, Y);
TControlAccess(FChild).OnMouseUp := FOldChildOnMouseUp;
end;
procedure TLongPressTracker.NewFormWndProc(var Message: TMessage);
begin
case Message.Msg of
WM_PARENTNOTIFY:
if TWMParentNotify(Message).Event = WM_LBUTTONDOWN then
StartTracking;
WM_LBUTTONDOWN:
StartTracking;
end;
with Message do
Result := CallWindowProc(FOldFormWndProc, FForm.Handle, Msg, WParam,
LParam);
end;
procedure TLongPressTracker.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (AComponent = FForm) and (Operation = opRemove) then
DetachForm;
if (AComponent = FChild) and (Operation = opRemove) then
begin
FTimer.Enabled := False;
FChild := nil;
end;
end;
procedure TLongPressTracker.SetDuration(Value: Cardinal);
begin
FTimer.Interval := Value;
end;
procedure TLongPressTracker.SetForm(Value: TCustomForm);
begin
if FForm <> Value then
begin
DetachForm;
FForm := Value;
FForm.FreeNotification(Self);
AttachForm;
end;
end;
procedure TLongPressTracker.StartTracking;
begin
FClickPos := Mouse.CursorPos;
FChild := FindControlAtPos(FForm, FClickPos);
FChild.FreeNotification(Self);
FPrevActiveControl := FForm.ActiveControl;
FOldChildOnMouseUp := TControlAccess(FChild).OnMouseUp;
TControlAccess(FChild).OnMouseUp := NewChildMouseUp;
FTimer.Enabled := True;
end;
end.
To get this component working, add it to a package, or use this runtime code:
...
private
procedure LongPress(Control: TControl);
end;
...
procedure TForm1.FormCreate(Sender: TObject);
begin
with TLongPressTracker.Create(Self) do
OnLongPress := LongPress;
end;
procedure TForm1.LongPress(Control: TControl);
begin
Caption := 'Long press occurred on: ' + Sender.ClassName;
end;
how can i have a image for Editbox background ?
This is very possible, indeed. In your form, define
private
{ Private declarations }
FBitmap: TBitmap;
FBrush: HBRUSH;
protected
procedure WndProc(var Message: TMessage); override;
and do
procedure TForm1.FormCreate(Sender: TObject);
begin
FBitmap := TBitmap.Create;
FBitmap.LoadFromFile('C:\Users\Andreas Rejbrand\Pictures\AS20Utv.bmp');
FBrush := 0;
FBrush := CreatePatternBrush(FBitmap.Handle);
end;
and
procedure TForm1.WndProc(var Message: TMessage);
begin
inherited;
case Message.Msg of
WM_CTLCOLOREDIT, WM_CTLCOLORSTATIC:
if (Message.LParam = Edit1.Handle) and (FBrush <> 0) then
begin
SetBkMode(Message.WParam, TRANSPARENT);
Message.Result := FBrush;
end;
end;
end;
Of course you can wrap this into a component of your own, say TEditEx. If I get time over, I might do this. (And, notice that there is no need to buy an expensive (and maybe not that high-quality) component pack from a third-party company.)