View Issue Details

IDProjectCategoryView StatusLast Update
0038099LazarusPackagespublic2020-11-20 12:08
ReporterAndy Spry Assigned ToBart Broersma  
PrioritynormalSeverityminorReproducibilityhave not tried
Status resolvedResolutionfixed 
Product Version2.0.8 
Summary0038099: TUpDown MouseDown event is not fired by left and right click on component buttons
DescriptionThe TUpDown MouseDown event is only fired when the mouse cursor is positioned in the narrow gap between the 2 buttons which makes it almost impossible to use the event.

In Delphi (7) the MouseDown event fires when the cursor is over the buttons and either mouse button is clicked.
TagsNo tags attached.
Fixed in Revisionr64147
LazTarget-
WidgetsetWin32/Win64
Attached Files

Relationships

related to 0038101 resolvedJuha Manninen TUpDown MouseEnter and MouseLeave events are not fired when the mouse cursor is over component buttons 

Activities

Bart Broersma

2020-11-17 19:00

developer   ~0127013

Presumably this goes for all OnMouseXXXX events?
Currently TUpDownButton (if we create that, seems to depend on WS) is unaware of the existence of the TUpDown that created it, so messages cannot be propagated.
Also X and Y values of the mouse then probably reflect the coördinates of the TUpDownButton, not of the TUpDown.

Bart Broersma

2020-11-17 21:05

developer   ~0127017

Last edited: 2020-11-17 21:12

View 2 revisions

My D7 publishes OnMouseUp, OnMouseDown, OnMouseMove.
Attached patch sort of implements this.
Sort of, because:
- order of events differs from Delphi
* Delphi: Click, MouseDown, MouseUp (always followed by MouseMove for some reason)
* Lazarus: MouseDown, MouseUp, Click
- X and Y are relative to TUpDownButton
- all this only workd if LCL actually creates TUpDownButtons in the first place (code suggests this is not always the case).

Please try with attached patch and give some feedback.

And from the WTF category: my D7 only fires OnClick if you click the "up" arrow, not if you click the "down" arrow.

Bart Broersma

2020-11-18 09:28

developer   ~0127024

New patch (updown.mouse-events.2.diff) more or less solves the issue wiht the X and Y coördinates.
updown.mouse-events.2.diff (2,141 bytes)   
Index: lcl/include/customupdown.inc
===================================================================
--- lcl/include/customupdown.inc	(revision 64121)
+++ lcl/include/customupdown.inc	(working copy)
@@ -20,11 +20,14 @@
     FMouseTimer : TTimer;
     FUpDown : TCustomUpDown;
     FButtonType : TUDBtnType;
+  private
+    procedure ButtonCoordToUpDownCoord(var X,Y: Integer);
   protected
     procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer
       ); override;
     procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
       override;
+    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
     procedure DblClick; override;
   public
     constructor CreateWithParams(UpDown : TCustomUpDown;
@@ -34,10 +37,28 @@
     procedure Paint; override;
   end;
 
+procedure TUpDownButton.ButtonCoordToUpDownCoord(var X, Y: Integer);
+begin
+  //Fix me: there must be a better way to do this?
+  //Result may be off by appr. 2 pixels
+  if FUpDown.Orientation = udVertical then
+  begin
+    if FButtonType = btPrev then //down arrow
+      Y := Y + Height; //assumes both buttons are equal height
+  end
+  else
+  begin
+    if FButtonType = btNext then //right arrow
+      X := X + Width;
+  end;
+end;
+
 procedure TUpDownButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
   Y: Integer);
 begin
   inherited MouseDown(Button, Shift, X, Y);
+  ButtonCoordToUpDownCoord(X, Y);
+  FUpDown.MouseDown(Button, Shift, X, Y);
   if Button = mbLeft then begin
     With FUpDown do begin
       FMouseTimerEvent := @Self.Click;
@@ -59,6 +80,8 @@
   Y: Integer);
 begin
   inherited MouseUp(Button, Shift, X, Y);
+  ButtonCoordToUpDownCoord(X, Y);
+  FUpDown.MouseUp(Button, Shift, X, Y);
   With FUpDown do
     If Assigned(FMouseTimer) then begin
       FreeAndNil(FMouseTimer);
@@ -67,6 +90,13 @@
     end;
 end;
 
+procedure TUpDownButton.MouseMove(Shift: TShiftState; X, Y: Integer);
+begin
+  inherited MouseMove(Shift, X, Y);
+  ButtonCoordToUpDownCoord(X, Y);
+  FUpDown.MouseMove(Shift, X, Y);
+end;
+
 procedure TUpDownButton.DblClick;
 begin
   Click;
updown.mouse-events.2.diff (2,141 bytes)   

Andy Spry

2020-11-18 13:22

reporter   ~0127028

Thank you Bart. I'm afraid you will have to be patient with me. I am very much an amateur.
I have patched your code and can confirm that both left and right mousedown events fire correctly. But I suspect I have done something wrong as the previous behaviour with a continuous left mouse down resulted in a continuous increment or decrement of Position. Now a Position change only occurs on MouseUp.
Please could you confirm the code..

procedure TUpDownButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
   Y: Integer);
 begin
   inherited MouseDown(Button, Shift, X, Y);
+ ButtonCoordToUpDownCoord(X, Y);
+ FUpDown.MouseDown(Button, Shift, X, Y);
   if Button = mbLeft then begin
     With FUpDown do begin
       FMouseTimerEvent := @Self.Click;
@@ -59,6 +80,8 @@
   Y: Integer); //should not be here???
 begin // :: ???
   inherited MouseUp(Button, Shift, X, Y);
+ ButtonCoordToUpDownCoord(X, Y);
+ FUpDown.MouseUp(Button, Shift, X, Y);
   With FUpDown do
     If Assigned(FMouseTimer) then begin
       FreeAndNil(FMouseTimer);
@@ -67,6 +90,13 @@
     end;
 end;


Please could you explain what @@ -67,6 +90,13 @@ means, for example - I have not included them in the patch, of course
Sorry.

Bart Broersma

2020-11-18 14:09

developer   ~0127029

Last edited: 2020-11-18 14:12

View 2 revisions

How did you apply my patch?
The @@ are there for the patch program, it indicates at what line (appr) the patch program searches for the next block
+ means: add this line
- means: delete this line

For humans, the patch file isn't always easy to interpret.

For me if I hold the mouse down on either of the arrows, it will continue to increase/decrese the associated control.
[Edit: Position is changed as expected also if Associate=nil]

Bart Broersma

2020-11-18 14:25

developer   ~0127030

I attached custumupdown.inc file.
You can do 2 things:
Make a backup of ($LazarusDir)\lcl\include\customupdown.inc
Copy the new customupdown.inc file to ($LazarusDir)\lcl\include (overwrite the old one), then rebuild your application.
The LCL should be rebuilt as well.
Since this file is now copied from the trunk version of Lazarus, there may be incompatibilities leading to compiler errors.
If it does not compile then do the following:

Restore the backup of custumupdown.inc
Open my version of customupdown.inc in an editor (e.g. notepad, or even the Lazarus IDE, but this may become confusing)
Open your test application in Lazarus
Navigate to the custumupdown.inc file (the original one).

In the class definition of TUpDownButton:
add (just above the protected section):
  private
    procedure ButtonCoordToUpDownCoord(var X,Y: Integer);

In the protected section add:
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;


Now, from my version of customupdown.inc file, copy the implementation of ButtonCoordToUpDownCoord and MouseMove.
Replace the old implementation of MouseUp and MouseDown with the ones in my file.

Save your copy of custumupdown.inc.
Rebuild your program, this should rebuild the LCL.
No compilation errors should occur inside customupdown.inc.
Test your application.

Report back.
customupdown.inc (19,315 bytes)   
{%MainUnit ../comctrls.pp}
{ TCustomUpDown

 *****************************************************************************
  This file is part of the Lazarus Component Library (LCL)

  See the file COPYING.modifiedLGPL.txt, included in this distribution,
  for details about the license.
 *****************************************************************************

Problems -
  - Doesn't draw Themed Arrows/doesn't match system colors
  - Associate Key down and Tabbing(VK_Up, VK_Down)
}
Type
  { TUpDownButton }

  TUpDownButton = Class(TSpeedButton)
  private
    FMouseTimer : TTimer;
    FUpDown : TCustomUpDown;
    FButtonType : TUDBtnType;
  private
    procedure ButtonCoordToUpDownCoord(var X,Y: Integer);
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer
      ); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure DblClick; override;
  public
    constructor CreateWithParams(UpDown : TCustomUpDown;
      ButtonType : TUDBtnType);

    procedure Click; override;
    procedure Paint; override;
  end;

procedure TUpDownButton.ButtonCoordToUpDownCoord(var X, Y: Integer);
begin
  //Fix me: there must be a better way to do this?
  //Result may be off by appr. 2 pixels
  if FUpDown.Orientation = udVertical then
  begin
    if FButtonType = btPrev then //down arrow
      Y := Y + Height; //assumes both buttons are equal height
  end
  else
  begin
    if FButtonType = btNext then //right arrow
      X := X + Width;
  end;
end;

procedure TUpDownButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  ButtonCoordToUpDownCoord(X, Y);
  FUpDown.MouseDown(Button, Shift, X, Y);
  if Button = mbLeft then begin
    With FUpDown do begin
      FMouseTimerEvent := @Self.Click;
      FMouseDownBounds := Bounds(Self.ClientOrigin.X, Self.ClientOrigin.Y,
        Self.Width,Self.Height);
      If Not Assigned(FMouseTimer) then
        FMouseTimer := TTimer.Create(FUpDown);
      With FMouseTimer do begin
        Enabled := False;
        Interval := 300;
        OnTimer := @BTimerExec;
        Enabled := True;
      end;
    end;
  end;
end;

procedure TUpDownButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited MouseUp(Button, Shift, X, Y);
  ButtonCoordToUpDownCoord(X, Y);
  FUpDown.MouseUp(Button, Shift, X, Y);
  With FUpDown do
    If Assigned(FMouseTimer) then begin
      FreeAndNil(FMouseTimer);
      FMouseDownBounds := Rect(0,0,0,0);
      FMouseTimerEvent := nil;
    end;
end;

procedure TUpDownButton.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseMove(Shift, X, Y);
  ButtonCoordToUpDownCoord(X, Y);
  FUpDown.MouseMove(Shift, X, Y);
end;

procedure TUpDownButton.DblClick;
begin
  Click;
end;

procedure TUpDownButton.Click;
begin
  with FUpDown do
  begin
    FCanChangePos := Position;
    FCanChangeDir := updNone;

    case FButtonType of
      btPrev :
        begin
          FCanChangeDir := updDown;

          if FCanChangePos - Increment >= Min then
            FCanChangePos := FCanChangePos - Increment
          else
            if Wrap then
              FCanChangePos := Max + (FCanChangePos - Increment - Min) + 1
          else
            FCanChangePos := Min;
        end;
      btNext :
        begin
          FCanChangeDir := updUp;

          if FCanChangePos + Increment <= Max then
            FCanChangePos := FCanChangePos + Increment
          else
            If Wrap then
              FCanChangePos := Min + (FCanChangePos + Increment - Max) - 1
          else
            FCanChangePos := Max;
        end;
        
    end;
    if not CanChange then Exit;
    Position := FCanChangePos;

    Click(FButtonType);
  end;
end;

constructor TUpDownButton.CreateWithParams(UpDown : TCustomUpDown;
  ButtonType : TUDBtnType);
begin
  Inherited Create(UpDown);
  FUpDown := UpDown;
  FButtonType := ButtonType;

  Parent := FUpDown;
  ControlStyle := ControlStyle + [csNoFocus, csNoDesignSelectable];
end;

procedure TUpDownButton.Paint;
var
  tmp : double;
  ax, ay, ah, aw : integer;
  j : integer;
begin
  Inherited Paint;
  if Enabled then
    Canvas.Pen.Color := clBtnText //Not perfect, but it works
  else
    Canvas.Pen.Color := clGrayText;

  ah := height div 2;
  aw := width div 2;

  if (FUpDown.Orientation = udHorizontal) then begin
    tmp := double(ah+1)/2;
    if (tmp > aw) then begin
      ah := 2*aw - 1;
      aw := (ah+1) div 2;
    end
    else begin
      aw := RoundToInt(tmp);
      ah := 2*aw - 1;
    end;
    aw := max(aw, 3);
    ah := max(ah, 5);
  end
  else begin
    tmp := double(aw+1)/2;

    if (tmp > ah) then begin
      aw := 2*ah - 1;
      ah := (aw+1) div 2;
    end
    else begin
      ah := RoundToInt(tmp);
      aw := 2*ah - 1;
    end;
    ah := max(ah, 3);
    aw := max(aw, 5);
  end;

  ax := (width - aw) div 2;
  ay := (height - ah) div 2;

  Case FButtonType of
    btPrev :
      begin
        If FUpDown.Orientation = udVertical then begin
          for j := 0 to aw div 2 do begin
            Canvas.MoveTo(ax + j, ay + j);
            Canvas.LineTo(ax + aw - j, ay + j);
          end;
        end
        else
          for j := 0 to ah div 2 do begin
            Canvas.MoveTo(ax + aw - j - 2, ay + j);
            Canvas.LineTo(ax + aw - j - 2, ay + ah - j - 1);
          end;
      end;
    btNext :
      begin
        If FUpDown.Orientation = udVertical then begin
          for j := 0 to aw div 2 do begin
            Canvas.MoveTo(ax + j, ay + ah - j - 1);
            Canvas.LineTo(ax + aw - j, ay + ah - j - 1);
          end;
        end
        else
          for j := 0 to ah div 2 do begin
            Canvas.MoveTo(ax + j, ay + j);
            Canvas.LineTo(ax + j, ay + ah - j - 1);
          end;
     end
  end;
end;

{ TCustomUpDown }

constructor TCustomUpDown.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle  - [csDoubleClicks] +
                  [csClickEvents, csOpaque, csReplicatable, csNoFocus];
  FUseWS := IsWSComponentInheritsFrom(TCustomUpDown, TWSCustomUpDown);
  FOrientation := udVertical;

  if not FUseWS then begin
    FMinBtn := TUpDownButton.CreateWithParams(Self, btPrev);
    FMaxBtn := TUpDownButton.CreateWithParams(Self, btNext);
  end;
  with GetControlClassDefaultSize do
    SetInitialBounds(0, 0, CX, CY);
  FArrowKeys := True;
  FMax := 100;
  FMinRepeatInterval := 100;
  FIncrement := 1;
  FAlignButton := udRight;
  FThousands := True;
end;

destructor TCustomUpDown.Destroy;
begin
  FAssociate := nil;
  inherited destroy;
end;

procedure TCustomUpDown.BTimerExec(Sender : TObject);
var
  AInterval:Integer;
begin
  If Assigned(FMouseTimerEvent)
     and PtInRect(FMouseDownBounds,Mouse.CursorPos) then begin
    AInterval := TTimer(Sender).Interval;
    if AInterval > FMinRepeatInterval then begin
      AInterval := AInterval - 25;
      if AInterval < FMinRepeatInterval then AInterval := FMinRepeatInterval;
      TTimer(Sender).Interval := AInterval;
    end;
    FMouseTimerEvent;
  end;
end;

procedure TCustomUpDown.UpdateUpDownPositionText;
begin
  if (not (csDesigning in ComponentState)) and (FAssociate <> nil)
  then begin
    if Thousands 
    then FAssociate.Caption := FloatToStrF(FPosition, ffNumber, 0, 0)
    else FAssociate.Caption := IntToStr(FPosition);
  end;
end;

class procedure TCustomUpDown.WSRegisterClass;
begin
  inherited WSRegisterClass;
  RegisterCustomUpDown;
end;

procedure TCustomUpDown.InitializeWnd;
begin
  inherited InitializeWnd;
  if not FUseWS then Exit;
  TWSCustomUpDownClass(WidgetSetClass).SetMinPosition(Self, FMin);
  TWSCustomUpDownClass(WidgetSetClass).SetMaxPosition(Self, FMax);
  TWSCustomUpDownClass(WidgetSetClass).SetPosition(Self, FPosition);
  TWSCustomUpDownClass(WidgetSetClass).SetIncrement(Self, FIncrement);
  TWSCustomUpDownClass(WidgetSetClass).SetWrap(Self, FWrap);
  TWSCustomUpDownClass(WidgetSetClass).SetOrientation(Self, FOrientation);
  TWSCustomUpDownClass(WidgetSetClass).SetUseArrowKeys(Self, FArrowKeys);
end;

procedure TCustomUpDown.UpdateOrientation;
var
  d, r: Integer;
begin
  if FUseWS then Exit;

  If FOrientation = udHorizontal then begin
    d:=ClientWidth div 2;
    r:=ClientWidth mod 2;
    FMinBtn.SetBounds(0,0,d,ClientHeight);
    FMaxBtn.SetBounds(d+r,0,d,ClientHeight);
  end
  else begin
    d:=ClientHeight div 2;
    r:=ClientHeight mod 2;
    FMaxBtn.SetBounds(0,0,ClientWidth,d);
    FMinBtn.SetBounds(0,d+r,ClientWidth,d);
  end;
end;

procedure TCustomUpDown.UpdateAlignButtonPos;
var
  NewWidth: Integer;
  NewLeft: Integer;
  NewHeight: Integer;
  NewTop: Integer;
begin
  If Assigned(Associate) then begin
    if FAlignButton in [udLeft,udRight] then begin
      NewWidth := Width;
      NewHeight := Associate.Height;
      If FAlignButton = udLeft then
        NewLeft := Associate.Left - NewWidth
      else
        NewLeft := Associate.Left + Associate.Width;
      NewTop := Associate.Top;
    end else begin
      NewWidth := Associate.Width;
      NewHeight := Height;
      NewLeft := Associate.Left;
      If FAlignButton = udTop then
        NewTop := Associate.Top - NewHeight
      else
        NewTop := Associate.Top + Associate.Height;
    end;
    SetBounds(NewLeft,NewTop,NewWidth,NewHeight);
  end;
end;

function TCustomUpDown.CanChange: Boolean;
begin
  Result := True;

  if Assigned(FOnChanging) then
    FOnChanging(Self, Result);

  if Assigned(FOnChangingEx) then
    FOnChangingEx(Self, Result, FCanChangePos, FCanChangeDir);
end;

procedure TCustomUpDown.Click(Button: TUDBtnType);
begin
  if Assigned(FOnClick) then FOnClick(Self, Button);
end;

procedure TCustomUpDown.SetAssociate(Value: TWinControl);
var
  I: Integer;
  OtherControl: TControl;
begin
  // check that no other updown component is associated to the new Associate
  if (Value <> FAssociate) and (Value<>nil) then
    for I := 0 to Parent.ControlCount - 1 do begin
      OtherControl:=Parent.Controls[I];
      if (OtherControl is TCustomUpDown) and (OtherControl <> Self) then
        if TCustomUpDown(OtherControl).Associate = Value then
          raise Exception.CreateFmt(rsIsAlreadyAssociatedWith,
                                    [Value.Name,OtherControl.Name]);
     end;

  // disconnect old Associate
  if FAssociate <> nil then
  begin
    FAssociate.RemoveAllHandlersOfObject(Self);
    FAssociate := nil;
  end;

  // connect new Associate
  if (Value <> nil) and (Value.Parent = Self.Parent)
  and not (Value is TCustomUpDown) and not (Value is TCustomTreeView)
  and not (Value is TCustomListView)
  then
  begin
    FAssociate := Value;
    UpdateUpDownPositionText;
    UpdateAlignButtonPos;
    FAssociate.AddHandlerOnKeyDown(@AssociateKeyDown,true);
    FAssociate.AddHandlerOnChangeBounds(@OnAssociateChangeBounds,true);
    FAssociate.AddHandlerOnEnabledChanged(@OnAssociateChangeEnabled,true);
    FAssociate.AddHandlerOnVisibleChanged(@OnAssociateChangeVisible,true);
    FAssociate.AddHandlerOnMouseWheel(@AssociateMouseWheel,true);
  end;
end;

procedure TCustomUpDown.AdjustPos(incPos: Boolean);
var
  anewpos: Integer;
begin
  if FUseWS then begin
    if incPos then anewpos := Position + Increment
    else anewpos := Position - Increment;

    if (anewpos < Min) then anewpos := Min
    else if (anewpos > Max) then anewpos := Max;
    SetPosition(anewpos);
  end else begin
    if incPos then TCustomSpeedButton(FMaxBtn).Click
    else TCustomSpeedButton(FMinBtn).Click;
  end;

end;

procedure TCustomUpDown.AssociateKeyDown(Sender: TObject; var Key: Word;
  ShiftState : TShiftState);
var
  ConsumeKey: Boolean;
begin
  ConsumeKey := False;
  if ArrowKeys and (ShiftState = []) then
  begin
    case FOrientation of
      udVertical:
        case Key of
          VK_Up:
            begin
              AdjustPos(True);
              ConsumeKey := True;
            end;
          VK_Down:
            begin
              AdjustPos(False);
              ConsumeKey := True;
            end;
        end;
      udHorizontal:
        case Key of
          VK_Left:
            begin
              AdjustPos(False);
              ConsumeKey := True;
            end;
          VK_Right:
            begin
              AdjustPos(True);
              ConsumeKey := True;
            end;
        end;
    end;
  end;
  if ConsumeKey then
    Key := 0;
end;

procedure TCustomUpDown.AssociateMouseWheel(Sender: TObject;
  Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint;
  var Handled: Boolean);

begin
  //debugln('TCustomUpDown.AssociateMouseWheel A: Handled = ',DbgS(Handled));
  if (WheelDelta > 0) then
  begin
    AdjustPos(True);
    Handled := True;
  end
  else if (WheelDelta < 0) then
  begin
    AdjustPos(False);
    Handled := True;
  end;
  //debugln('TCustomUpDown.AssociateMouseWheel End: Handled = ',DbgS(Handled));
end;

procedure TCustomUpDown.OnAssociateChangeBounds(Sender: TObject);
begin
  UpdateAlignButtonPos;
end;

procedure TCustomUpDown.OnAssociateChangeEnabled(Sender: TObject);
begin
  if Assigned(FAssociate) then
    SetEnabled(FAssociate.Enabled);
end;

procedure TCustomUpDown.OnAssociateChangeVisible(Sender: TObject);
begin
  if Assigned(FAssociate) then
    SetVisible(FAssociate.Visible);
end;

function TCustomUpDown.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean;
begin
  Result := inherited DoMouseWheelDown(Shift, MousePos);
  if not Result and not FUseWS then
    TCustomSpeedButton(FMinBtn).Click;
end;

function TCustomUpDown.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean;
begin
  Result := inherited DoMouseWheelUp(Shift, MousePos);
  if not Result and not FUseWS then
    TCustomSpeedButton(FMaxBtn).Click;
end;

function TCustomUpDown.DoMouseWheelLeft(Shift: TShiftState; MousePos: TPoint): Boolean;
begin
  Result := inherited DoMouseWheelLeft(Shift, MousePos);
  if not Result then
    if (Orientation=udHorizontal) and not FUseWS  then
      TCustomSpeedButton(FMinBtn).Click;
end;

function TCustomUpDown.DoMouseWheelRight(Shift: TShiftState; MousePos: TPoint): Boolean;
begin
  Result := inherited DoMouseWheelRight(Shift, MousePos);
  if not Result then
    if (Orientation=udHorizontal) and not FUseWS then
      TCustomSpeedButton(FMaxBtn).Click;
end;

procedure TCustomUpDown.DoSetBounds(ALeft, ATop, AWidth, AHeight: integer);
begin
  inherited;
  UpdateOrientation;
end;

procedure TCustomUpDown.SetEnabled(Value: Boolean);
begin
  if not FUseWS then
  begin
    FMinBtn.Enabled := Value;
    FMaxBtn.Enabled := Value;
  end;
  inherited SetEnabled(Value);
end;

class function TCustomUpDown.GetControlClassDefaultSize: TSize;
begin
  Result.CX := 17;
  Result.CY := 31;
end;

procedure TCustomUpDown.CalculatePreferredSize(var PreferredWidth,
  PreferredHeight: integer; WithThemeSpace: Boolean);
begin
  case Orientation of
  udHorizontal:
    begin
      PreferredWidth:=31;
      PreferredHeight:=17;
    end;
  udVertical:
    begin
      PreferredWidth:=17;
      PreferredHeight:=31;
    end;
  end;
end;

procedure TCustomUpDown.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FAssociate) then
    SetAssociate(nil);
end;

function TCustomUpDown.GetPosition: SmallInt;
var
  av,I : Integer;
  str : string;
  InvalidNumber : Boolean;
begin
  If Associate <> nil then begin
    str := Trim(Associate.Caption);
    str := StringReplace(str, DefaultFormatSettings.ThousandSeparator, '', [rfReplaceAll]);
    if not TryStrToInt(str, AV) then
    begin
      Result := FPosition;
      Exit;
    end;
    //this will also correct for AV > High(SmallInt) or AV < Low(SMallInt)
    If AV > FMax then
      AV := FMax;
    If AV < FMin then
      AV := FMin;
    Position := AV;
  end;
  Result := FPosition;
end;

function TCustomUpDown.GetFlat: Boolean;
begin
  if FUseWS then
    Result := false
  else if FMinBtn<>nil then
    Result := (FMinBtn as TSpeedButton).Flat
  else
    Result := False;
end;

procedure TCustomUpDown.SetMin(Value: SmallInt);
begin
  if Value <> FMin then
  begin
    FMin := Value;
    If FPosition < FMin then
      Position := FMin;
    if FUseWS then
      TWSCustomUpDownClass(WidgetSetClass).SetMinPosition(Self, FMin);
  end;
end;

procedure TCustomUpDown.SetMinRepeatInterval(AValue: Byte);
begin
  if FMinRepeatInterval = AValue then Exit;
  FMinRepeatInterval := AValue;
  if FMinRepeatInterval < 25 then FMinRepeatInterval := 25;
end;

procedure TCustomUpDown.SetMax(Value: SmallInt);
begin
  if Value <> FMax then
  begin
    FMax := Value;
    If FPosition > FMax then
      Position := FMax;
    if FUseWS then
      TWSCustomUpDownClass(WidgetSetClass).SetMaxPosition(Self, FMax);
  end;
end;

procedure TCustomUpDown.SetIncrement(Value: Integer);
begin
  if Value <> FIncrement then begin
    FIncrement := Value;
    if FUseWS then
      TWSCustomUpDownClass(WidgetSetClass).SetIncrement(Self, FIncrement);
  end;
end;

procedure TCustomUpDown.SetPosition(Value: SmallInt);
begin
  if FPosition = Value then exit;
  FPosition := Value;
  if FUseWS then
    TWSCustomUpDownClass(WidgetSetClass).SetPosition(Self, FPosition);
  UpdateUpDownPositionText;
end;

procedure TCustomUpDown.SetOrientation(Value: TUDOrientation);
begin
  if FOrientation = Value then exit;
  FOrientation := Value;
  if FUseWS then
    TWSCustomUpDownClass(WidgetSetClass).SetOrientation(Self, FOrientation);

  UpdateOrientation;
end;

procedure TCustomUpDown.SetAlignButton(Value: TUDAlignButton);
begin
  if FAlignButton = Value then exit;
  FAlignButton := Value;
  UpdateAlignButtonPos;
end;

procedure TCustomUpDown.SetArrowKeys(Value: Boolean);
begin
  if Value <> FArrowKeys then begin
    FArrowKeys := Value;
    if FUseWS then
      TWSCustomUpDownClass(WidgetSetClass).SetUseArrowKeys(Self, Value);
  end;
end;

procedure TCustomUpDown.SetThousands(Value: Boolean);
begin
  if Value <> FThousands then
    FThousands := Value;
end;

procedure TCustomUpDown.SetFlat(Value: Boolean);
begin
  if FUseWS then Exit; // todo: not supported by WS yet
  if Flat = Value then Exit;

  (FMinBtn as TSpeedButton).Flat := Value;
  (FMaxBtn as TSpeedButton).Flat := Value;
end;

procedure TCustomUpDown.SetWrap(Value: Boolean);
begin
  if Value <> FWrap then
    FWrap := Value;
  if FUseWS then
    TWSCustomUpDownClass(WidgetSetClass).SetWrap(Self, FWrap);
end;

// included by comctrls.pp

customupdown.inc (19,315 bytes)   

Andy Spry

2020-11-18 15:08

reporter   ~0127031

I took the easy route and overwrote the original with your new version. There were no compilation problems or errors. MouseUp and and MouseDown work fine. Continued mouse down continuously increments/decrements Position.

But while I am being a nuisance, I did note that MouseEnter only fires with the mouse cursor in that narrow gap (that is, not over the buttons) or on a MouseUp event.

Thank you, Bart

Andy Spry

2020-11-18 15:19

reporter   ~0127032

Oops. Forget the bit about MouseEnter firing on MouseUp. It doesn't. Just another mistake of mine.

Bart Broersma

2020-11-18 17:30

developer   ~0127036

Yes, MouseEnter/MouseLeave do not fire.
I cannot even get my mouse (trackpad) to hover over the narrow gap.
Problem is that I cannot simply forward the button's MouseEnter/MouseLeave, because that would fire also if you move from one button to the other.

I will first commit the changes I made for MouseDown/MouseUp.

Can you please open a separate bugreport for MouseEnter/MouseLeave, so we can continue there.

Issue History

Date Modified Username Field Change
2020-11-17 17:53 Andy Spry New Issue
2020-11-17 19:00 Bart Broersma Note Added: 0127013
2020-11-17 21:05 Bart Broersma Status new => feedback
2020-11-17 21:05 Bart Broersma LazTarget => -
2020-11-17 21:05 Bart Broersma Note Added: 0127017
2020-11-17 21:12 Bart Broersma Note Edited: 0127017 View Revisions
2020-11-18 09:28 Bart Broersma Note Added: 0127024
2020-11-18 09:28 Bart Broersma File Added: updown.mouse-events.2.diff
2020-11-18 13:22 Andy Spry Note Added: 0127028
2020-11-18 13:22 Andy Spry Status feedback => new
2020-11-18 14:09 Bart Broersma Note Added: 0127029
2020-11-18 14:12 Bart Broersma Note Edited: 0127029 View Revisions
2020-11-18 14:25 Bart Broersma Note Added: 0127030
2020-11-18 14:25 Bart Broersma File Added: customupdown.inc
2020-11-18 14:26 Bart Broersma Assigned To => Bart Broersma
2020-11-18 14:26 Bart Broersma Status new => feedback
2020-11-18 15:08 Andy Spry Note Added: 0127031
2020-11-18 15:08 Andy Spry Status feedback => assigned
2020-11-18 15:19 Andy Spry Note Added: 0127032
2020-11-18 17:30 Bart Broersma Note Added: 0127036
2020-11-18 17:32 Bart Broersma Status assigned => resolved
2020-11-18 17:32 Bart Broersma Resolution open => fixed
2020-11-18 17:32 Bart Broersma Fixed in Revision => r64147
2020-11-18 17:32 Bart Broersma Widgetset Win32/Win64 => Win32/Win64
2020-11-20 12:08 Juha Manninen Relationship added related to 0038101