TListBox OnClick not working just on some machines ?

[Gustav Schubert 27]

I have a strange problem with FMX TListbox and the OnClick handler, but apparrently only on my Surface tablet. Cannot reproduce on another machine. Initially I thought it was a strange HDPI related issue, now I think it may be 'just' a driver issue. The first comment contains the test program. It would be interesting if someone can reproduce. Details in comments below. I'm sorry if this turns out to be noise. Symptoms: If I click on a ListBox item then ItemIndex in ListboxClick is wrong, it contains the index of the previously clicked item.

Edited August 7, 2020 by Gustav Schubert
Complete rewrite of the post, much shorter.

[Gustav Schubert 27]

unit FrmMain;

interface

uses
  System.SysUtils,
  System.Types,
  System.UITypes,
  System.Classes,
  FMX.Types,
  FMX.Controls,
  FMX.Forms,
  FMX.Graphics,
  FMX.Layouts,
  FMX.ListBox,
  FMX.ListView.Types,
  FMX.ListView.Appearances,
  FMX.ListView.Adapters.Base,
  FMX.ListView;

type
  TFormMain = class(TForm)
    ListBox: TListBox;
    ListView: TListView;
    procedure FormCreate(Sender: TObject);
    procedure ListBoxClick(Sender: TObject);
    procedure ListBoxKeyUp(Sender: TObject; var Key: Word;
      var KeyChar: Char; Shift: TShiftState);
    procedure ListViewItemClick(const Sender: TObject;
      const AItem: TListViewItem);
    procedure FormDestroy(Sender: TObject);
  private
    Counter: Integer;
    ML: TStrings;
  end;

var
  FormMain: TFormMain;

implementation

{$R *.fmx}

procedure TFormMain.FormCreate(Sender: TObject);
var
  i: Integer;
  li: TListViewItem;
begin
  ReportMemoryLeaksOnShutdown := True;

  ML := TStringList.Create;
  ML.Add('Item 0');
  ML.Add('Item 1');
  ML.Add('Item 2');
  ML.Add('Item 3');

  Listbox.Items := ML;

  ListView.ItemAppearanceName := 'ListItem';
  ListView.ItemAppearance.ItemHeight := 24;
  ListView.ItemAppearanceObjects.ItemObjects.Accessory.Visible := False;
  ListView.ItemAppearanceObjects.ItemObjects.Text.Font.Family := 'Consolas';
  ListView.ItemAppearanceObjects.ItemObjects.Text.Font.Size := 16;
  ListView.ItemAppearanceObjects.ItemObjects.Text.TextColor := TAlphaColors.Dodgerblue;
  ListView.ItemAppearanceObjects.HeaderObjects.Text.Visible := False;
  ListView.ItemAppearanceObjects.FooterObjects.Text.Visible := False;
  ListView.OnItemClick := ListViewItemClick;

  for i := 0 to ML.Count-1 do
  begin
    li := ListView.Items.Add;
    li.Text := ML[i];
  end;
end;

procedure TFormMain.FormDestroy(Sender: TObject);
begin
  ML.Free;
end;

procedure TFormMain.ListViewItemClick(const Sender: TObject; const AItem: TListViewItem);
var
  ii: Integer;
begin
  ii := AItem.Index;
  if ii > -1 then
  begin
    Inc(Counter);
    Caption := ML[ii] + ' - ' + IntToStr(Counter);
  end;
end;

procedure TFormMain.ListBoxClick(Sender: TObject);
var
  ii: Integer;
begin
  if ListBox.Selected = nil then
  begin
    Inc(Counter);
    Exit;
  end;

  ii := ListBox.ItemIndex;
  if ii > -1 then
  begin
    Inc(Counter);
    Caption := ML[ii] + ' - ' + IntToStr(Counter);
  end;
end;

procedure TFormMain.ListBoxKeyUp(Sender: TObject; var Key: Word;
  var KeyChar: Char; Shift: TShiftState);
begin
  if KeyChar = ' ' then
    ListBoxClick(nil);
end;

end.

 

[Rollo62 595]

OnItemClick

Your second post shows that too, is that the solution or does it have an issue ?

[Gustav Schubert 27]

No solution so far, just the test project which will show the issue. Whether OnClick 'works' depends on where you test. On my Surface tablet it it does not work. ItemIndex will be the previously clicked item, not the item you just clicked on. And the first time you click, the handler will not be called at all. Latest: I verified that OnChange works as expected, and I looked up the specific model info of the problem device:

 

procedure TFormMain.ListBoxChange(Sender: TObject);
begin
  { works as expected } 
//  HandleClick(Listbox.ItemIndex);
end;

procedure TFormMain.ListBoxClick(Sender: TObject);
begin
  { does not work on Surface Pro (5. Gen), Modell 1796 m3 }
  HandleClick(Listbox.ItemIndex);
end;

procedure TFormMain.HandleClick(ii: Integer);
begin
  if ii > -1 then
  begin
    Inc(Counter);
    Caption := ListBox.Items[ii] + ' - ' + IntToStr(Counter);
  end;
end;

 

Edited August 8, 2020 by Gustav Schubert
progress with testing

[Gustav Schubert 27]

Update - the problem is reproducible on my Surface tablet with scaling 2.0, but not - as I have just learned - on my Retina iMac with the same scaling, in the bootcamp partition. Surprise.

Edited August 7, 2020 by Gustav Schubert
more info needed

[Gustav Schubert 27]

I used PAServer and 64 Bit remote debugging - for the first time - to find out more, with two breakpoints:

1) One breakpoint in OnClick handler.
2) Another breakpoint in TListBoxSelector.SetCurrent.

 

I got different call stacks between Desktop and Tablet. On the tablet computer the OnClick handler is called before the first call to SetCurrent. And this is the very problem! It is of course important that TListBoxSelector.FCurrent be set to the correct value before my OnClick handler is called.

 

    /// <summary>Timer used for DelayedMouseDown</summary>
    FSelectionTimer: TTimer;

function TListBoxSelector.SetCurrent(const Index: Integer): Boolean;
begin
  Result := FCurrent <> Index;
  FCurrent := Index; // <-- ItemIndex
end;

procedure TListBoxSelector.MouseSelectStart(const Item: TListBoxItem; const Button: TMouseButton;
  const Shift: TShiftState);
begin
  if Button <> TMouseButton.mbLeft then
    Exit;
  if (FListBox.AniCalculations.TouchTracking <> []) and (Item.Index <> FCurrent) then
    DelayedMouseDown(Item, Shift) // <-- Surface tablet
  else
    DoMouseSelectStart(Item, Shift); // <-- Desktop
end;

procedure TListBoxSelector.DelayedMouseDown(const ItemDown: TListBoxItem; const Shift: TShiftState);
begin
  if FSelectionTimer = nil then
    FSelectionTimer := TSelectionTimer.CreateTimer(Self);
  TSelectionTimer(FSelectionTimer).Reload(ItemDown, Shift);
end;

Now I am confident that some of you will be able to reproduce. 

[Gustav Schubert 27]

Just found out that it is an already Open issue:

 

RSP-19266

You can create a test environment for the issue on the desktop which should be good enough to investigate, by changing one line in the implementation section, in a copy of unit FMX.ListBox.

procedure TListBoxSelector.MouseSelectStart(const Item: TListBoxItem; const Button: TMouseButton;
  const Shift: TShiftState);
begin
  if Button <> TMouseButton.mbLeft then
    Exit;
//  if (FListBox.AniCalculations.TouchTracking <> []) and (Item.Index <> FCurrent) then
  if (Item.Index <> FCurrent) then
    DelayedMouseDown(Item, Shift)
  else
    DoMouseSelectStart(Item, Shift);
end;

 

[Gustav Schubert 27]

I can register my own TListBoxSelector derived class and then create a TListBox at runtime, which uses the custom TListBoxSelector, but the classes to inherit from are all private, defined in implementation section of FMX.ListBox.Selection. I did it anyway, just to test out if it works.

procedure TRggSelectionController.MouseSelectStart(const Item: TListBoxItem; const Button: TMouseButton;
  const Shift: TShiftState);
begin
  if Button <> TMouseButton.mbLeft then
    Exit;
//  if (FListBox.AniCalculations.TouchTracking <> []) and (Item.Index <> FCurrent) then
//    DelayedMouseDown(Item, Shift)
//  else
    DoMouseSelectStart(Item, Shift);
end;

{ in FormCreate: }
  TListBoxSelectorFactory.RegisterSelector(TMultiSelectStyle.None, TRggSelectionController);

  ListBox.Free;

  ListBox := TListBox.Create(Self);
  ListBox.Parent := Self;
  ListBox.Position.Y := 100;
  ListBox.Position.Y := 200;
  ListBox.OnClick := ListBoxClick;

I am using the Listbox in a desktop application, and when I am navigating the items with the arrow keys, I do not want to do anything immediately. Only when the user clicks, or presses the space character, should an action be triggered. That is why I tried with OnClick instead of OnChange. OnChange is working, but it is called before OnClick, so I cannot just set a flag in OnClick, to be evaluated in OnChange, that does not work.
 

Best workaround still to be determined.

[Gustav Schubert 27]

OK, OnItemClick is much better, got it - only now. Perhaps OnClick should be deprecated?

https://stackoverflow.com/questions/48813666/firemonkey-tlistbox-onclick-which-item-is-clicked
https://stackoverflow.com/questions/19822639/translating-onclick-to-ontouch-or-something-similiar
 

[Gustav Schubert 27]

Since I have 'played' with TSingleSelectionController a bit, I want to disclose a Feature!

 

With TMultiSelectStye.None (the default for TListBox), it is still possible to select more then one Item, albeit with the illegal help of the right mouse button.

 

This is because the right mouse button will set FCurrent, wich will then derail the proper deselection of the previously selected item - when you left click on another item, which is not the selected and not the current.

 

In other words, the Selected Item and the Current Item may get out of sync when the user is trying something wierd with left and right mouse buttons.

 

Note: On the touch screen, a long tap maps to right mouse button.

{
Playing with 4 Items:

1) Click Item 1 with left mouse button.
  Item 1 becomes selected
  FCurrent := 1

2) Click Item 3 with right mouse button
  Item 1 still selected
  Item 3 not selected
  FCurrent := 3

3) Click Item 2 with left mouse button
  FCurrent = 3 (still, when DoMouseSelectStart is called)
  Item 3 will be deselected (but it was not selected, no change)
  Item 2 becomes selected as well
  Item 1 still selected
  FCurrent := 2 ( after click)
}

procedure TSingleSelectionController.DoMouseSelectStart(const Item: TListBoxItem; const Shift: TShiftState);
begin
  if (FUserSetIndex = -1) and (Item.Index <> FCurrent) then
  begin
    { will deselect current }
    SetSelected(GetCurrentItem, False); // <-- depends on FCurrent being 'correct'
    if SetCurrent(Item.Index) then
      Item.SetIsSelectedInternal(True, False);
  end;
end;

 

[Gustav Schubert 27]

3 hours ago, Gustav Schubert said:

SetSelected(GetCurrentItem, False); // <-- depends on FCurrent being 'correct'

ClearSelection;

Now only one item will be shown as selected at any time,

 

But FCurrent alias ItemIndex can still be changed with right mouse button click on another item, without beeing reflected by the visual selection.

 

Which should be dealt with in MouseSelectFinish?

procedure TRggSelectionController.MouseSelectFinish(const Item: TListBoxItem; const Button: TMouseButton;
  const Shift: TShiftState);
begin
  { added test for button }
  if Button <> TMouseButton.mbLeft then
    Exit;
  inherited;
end;

 

Edited August 10, 2020 by Gustav Schubert
added second part of possible fix

[Rollo62 595]

Maybe that helps too.

I basically moved to TListView, since I find the more reliable supported than TListBox.

Although TListBox would be handy in most places.

[Gustav Schubert 27]

Best practice recommendations:

 

For simple case of ListBox with 4 Items, only one of which should be selectable, do this:

 

a) use OnItemClick, not OnClick
b) use TMultiSelectStyle.Default, not TMultiSelectStyle.None (the default)
c) do not use the right mouse button to select items

d) use TListView if you can

 

My new minimal example - which monitors ItemIndex - shows that the right mouse button can change ItemIndex, so that it becomes out of sync with the selection.

unit FrmMain;

interface

uses
  System.SysUtils,
  System.Classes,
  FMX.Controls.Presentation,
  FMX.Forms,
  FMX.Graphics,
  FMX.ListBox,
  FMX.StdCtrls,
  FMX.Objects,
  FMX.Layouts,
  FMX.Types,
  FMX.Controls;

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Text1: TText;
    NoneBtn: TSpeedButton;
    DefaultBtn: TSpeedButton;
    ExtendedBtn: TSpeedButton;
    procedure FormCreate(Sender: TObject);
    procedure ListBox1ItemClick(const Sender: TCustomListBox; const Item: TListBoxItem);
    procedure NoneBtnClick(Sender: TObject);
    procedure DefaultBtnClick(Sender: TObject);
    procedure ExtendedBtnClick(Sender: TObject);
  private
    procedure DoOnIdle(Sender: TObject; var Done: Boolean);
  end;

var
  Form1: TForm1;

implementation

{$R *.fmx}

procedure TForm1.NoneBtnClick(Sender: TObject);
begin
  ListBox1.MultiSelectStyle := TMultiSelectStyle.None;
end;

procedure TForm1.DefaultBtnClick(Sender: TObject);
begin
  ListBox1.MultiSelectStyle := TMultiSelectStyle.Default;
end;

procedure TForm1.ExtendedBtnClick(Sender: TObject);
begin
  ListBox1.MultiSelectStyle := TMultiSelectStyle.Extended;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  gn: string;
  ML: TStrings;
begin
  ReportMemoryLeaksOnShutdown := True;

  ML := ListBox1.Items;
  ML.Add('Item 0');
  ML.Add('Item 1');
  ML.Add('Item 2');
  ML.Add('Item 3');

  ListBox1.MultiSelectStyle := TMultiSelectStyle.Default;
  ListBox1.OnItemClick := ListBox1ItemClick;

  NoneBtn.StaysPressed := True;
  DefaultBtn.StaysPressed := True;
  ExtendedBtn.StaysPressed := True;

  NoneBtn.IsPressed := ListBox1.MultiSelectStyle = TMultiSelectStyle.None;
  DefaultBtn.IsPressed := ListBox1.MultiSelectStyle = TMultiSelectStyle.Default;
  ExtendedBtn.IsPressed := ListBox1.MultiSelectStyle = TMultiSelectStyle.Extended;

  gn := 'MultiSelectEnum';
  NoneBtn.GroupName := gn;
  DefaultBtn.GroupName := gn;
  ExtendedBtn.GroupName := gn;

  Application.OnIdle := DoOnIdle;
end;

procedure TForm1.ListBox1ItemClick(const Sender: TCustomListBox;
  const Item: TListBoxItem);
begin
  Caption := IntToStr(Item.Index);
end;

procedure TForm1.DoOnIdle(Sender: TObject; var Done: Boolean);
begin
  Text1.Text := IntToStr(ListBox1.ItemIndex);
  Done := True;
end;

end.

( Using a class helper for TListBoxSelector.MouseSelectFinish is not possible. )

Edited August 11, 2020 by Gustav Schubert
added Praxis point d)

[Gustav Schubert 27]

No need to report the right mouse button bug, it exists already.

 

RSP-28235

 

But I think I have the solution:

procedure TListBoxSelector.MouseSelectFinish(const Item: TListBoxItem; const Button: TMouseButton;
  const Shift: TShiftState);
begin
  if Button <> TMouseButton.mbLeft then
  begin    
    DoMouseSelectStart(Item, Shift);
  end;
  DoMouseSelectFinish(Item, Shift);
end;

 

Edited August 11, 2020 by Gustav Schubert
added code

[Gustav Schubert 27]

I am adding an explanation for the solution and then a question.
 

Explanation

• The selection of Items in a ListBox is supposed to be done with the left mouse button down or with a single finger on a touchscreen.
• There is a bug - when you use the right mouse button on the desktop. It will set ItemIndex but will not update the selection.
• It turns out that it is difficult to prevent this.
• And this difficulty led me to the solution.
• Rather than to prevent the use of the right and middle mouse buttons to change ItemIndex - I will try to do it properly.
• To do it properly means that the selection should be updated.
• Wild guess: "It is difficult to finish what you have not started."
• So you better start the thing before you finish it?
• See code - it works.

imlementation

type
  TSingleSelectionController = class(TListBoxSelector)
  public
    { to be explained: }
    procedure MouseSelectFinish(const Item: TListBoxItem;
      const Button: TMouseButton; const Shift: TShiftState); override;
  end;

procedure TSingleSelectionController.MouseSelectFinish(const Item: TListBoxItem;
  const Button: TMouseButton; const Shift: TShiftState);
begin
  { Only one new line;-) }
  if Button <> TMouseButton.mbLeft then DoMouseSelectStart(Item, Shift);

  DoMouseSelectFinish(Item, Shift);
end;

end.

Question

 

What hack can I apply to

a) replace one public virtual method in TListBoxSelection? or
b) override one public virtual method in TSingleSelectionController?

 

So far I made the change in a copy of the unit -
a) FMX.ListBox for TListBoxSelection or
b) FMX.ListBox.Selection for TSingleSelectionController

 

( The problem is of course that TListBoxSelection is public but abstract, and concrete classes are declared in the implementation section. )
 

A patched version of TSingleSelectionController will be used in the minimal test project below.

implementation

{$R *.fmx}

procedure TForm1.FormCreate(Sender: TObject);
var
  i: Integer;
begin
{ TMultiSelectionStyle.None  --> TSingleSelectionController }
{ TMultiSelectionStyle.Default --> TMultiSelectionController }
{ TMultiSelectionStyle.Extended --> TExtendedSelectionController }

  ListBox1.MultiSelectStyle := TMultiSelectStyle.None;

  with ListBox1.Items do
  begin
    for i in [0..3] do
      Add('Item ' + IntToStr(i));
  end;

  Application.OnIdle := DoOnIdle;
end;

procedure TForm1.DoOnIdle(Sender: TObject; var Done: Boolean);
begin
  Caption := IntToStr(ListBox1.ItemIndex);
  Done := True;
end;

end.

The hack I am asking for should not copy whole units!

Edited August 15, 2020 by Gustav Schubert
typo

[Gustav Schubert 27]

I have applied info from "Patch a private virtual method" topic.
 

My fix as a patch in a minimal test project:

unit Unit1;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Controls.Presentation, FMX.ListBox;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    LB: TListBox;
    SC: TListBoxSelector;
    function GetVirtualMethodIndex: Integer;
    procedure DoOnIdle(Sender: TObject; var Done: Boolean);
    procedure PatchMouseSelectFinish;
  protected
    procedure InspectVMT(const AMethodName: string);
  end;

var
  Form1: TForm1;

implementation

{$R *.fmx}

uses
  Windows,
  System.Rtti;

const
  MSF_MethodName = 'MouseSelectFinish';

type
  TListBoxAccess = class(TListBox);

  TMouseSelectProc = procedure(
    const Item: TListBoxItem;
    const Button: TMouseButton;
    const Shift: TShiftState) of object;

procedure FixedMouseSelectFinish(Self: TListBoxSelector;
  const Item: TListBoxItem;
  const Button: TMouseButton;
  const Shift: TShiftState);
begin
  if Button <> TMouseButton.mbLeft then
    Self.DoMouseSelectStart(Item, Shift);
  Self.DoMouseSelectFinish(Item, Shift);
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  i: Integer;
begin
  LB := TListBox.Create(Self);
  LB.Parent := Self;
  { works for other MultiSelectStyles too }
  LB.MultiSelectStyle := TMultiSelectStyle.None;

  with LB.Items do
  begin
    for i in [0..3] do
      Add('Item ' + IntToStr(i));
  end;

  { we need to know the class type of the SelectionController }
  SC := TListBoxAccess(LB).SelectionController;
  PatchMouseSelectFinish; // of the actual SC

  { Needed to see whether ListBox selection 'works' as expected,
    when you click on items with the right mouse button. }
  Application.OnIdle := DoOnIdle;

  { Optional, for more info ... }
//  LB.Align := TAlignLayout.Client;
//  InspectVMT('');
end;

procedure TForm1.PatchMouseSelectFinish;
var
  p: Pointer;
  n: UINT_PTR;
  vi: Integer;
begin
//  vi := 7; { known value in 10.3.3 }
  vi := GetVirtualMethodIndex;

  if vi > 0 then
  begin
  { see https://en.delphipraxis.net/topic/1922-patch-a-private-virtual-method/ }
{$POINTERMATH ON}
    p := @FixedMouseSelectFinish;
    WriteProcessMemory(
      GetCurrentProcess,
      @PPointer(SC.ClassType)[vi],
      @p,
      SizeOf(Pointer),
      n);
  end;
end;

function TForm1.GetVirtualMethodIndex: Integer;
var
  LContext: TRttiContext;
  LType: TRttiType;
  LMethods: TArray<TRttiMethod>;
  l: Integer;
  m: TRttiMethod;
begin
  { get the index of the public virtual method in VMT,
    of the class that is actually used,
    a descendent of TListBoxSelector }
  result := -1;
  LContext := TRttiContext.Create;
  try
    LType := LContext.GetType(SC.ClassType);
    LMethods := LType.GetMethods('MouseSelectFinish');
    l := Length(LMethods);
    if l > 0 then
    begin
      { we want the first one }
      m := LMethods[0];
      result := m.VirtualIndex;
    end;
  finally
    LContext.Free;
  end;
end;

procedure TForm1.InspectVMT(const AMethodName: string);
var
  LContext: TRttiContext;
  LType: TRttiType;
  LMethods: TArray<TRttiMethod>;
  i: Integer;
  rm: TRttiMethod;
  mn: string;
  cn: string;
  vi: Integer;
begin
  LB.Items.Clear;
  LContext := TRttiContext.Create;
  try
    LType := LContext.GetType(SC.ClassType);
    if AMethodName = '' then
      LMethods := LType.GetMethods
    else
      LMethods := LType.GetMethods(AMethodName);
    for i := 0 to Length(LMethods) - 1 do
    begin
      rm := LMethods[i];
      cn := rm.Parent.Name;
      mn := rm.ToString;
      vi := rm.VirtualIndex;
      LB.Items.Add(Format('%3d %p %s.%s', [vi, rm.CodeAddress, cn, mn]));
    end;
  finally
    LContext.Free;
  end;
end;

procedure TForm1.DoOnIdle(Sender: TObject; var Done: Boolean);
begin
  Caption := IntToStr(LB.ItemIndex);
  Done := True;
end;

end.

I am patching a public virtual method that appears in TListBoxSelector, which is NOT overridden in TSingleSelectionController.

 

VMT, from the styled test poject (not minimal):

 

 

Notes:

The root problem is with concrete classes declared in implementation section.

a) I cannot typecast to these types.
  MethodPtr := TSingleSelectionController(@VMT).MouseSelectFinish; // nope
  MethodPtr := TRggSelectionController(@VMT).MouseSelectFinish; // ok

b) In ( for LType in LContext.GetTypes do ) I cannot find a type by name,
   by checking for (LType.Name = 'TSingleSelectionController') // nope
   by checking for (LType.Name = 'TRggSelectionController') // ok.

c) But I can do LType := LContext.GetType(SC.ClassType); // SC = TSingleSelectionController

So, I could make use of VirtualIndex because I got Access to the type first, via TListBoxAccess. -  You can test out my fix if you want.

Edited September 8, 2020 by Gustav Schubert
added link