How to get rid of TListBox vertical scroll limit?

[亡魂溺海] 提交于 2019-12-03 13:34:12

The below probably should be considered as a work-around for defective OS behavior, since, unless themes are enabled, the default window procedure of a listbox control handles thumb-tracking quite well. For some reason, when themes are enabled (test here shows with Vista and later), the control seems to rely upon the Word sized scroll position data of WM_VSCROLL.

First, a simple project to duplicate the problem, below is an owner draw virtual (lbVirtualOwnerDraw) list box with some 600,000 items (since item data is not cached it doesn't take a moment to populate the box). A tall listbox will be good for easy following the behavior:

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    procedure ListBox1Data(Control: TWinControl; Index: Integer;
      var Data: string);
    procedure ListBox1DrawItem(Control: TWinControl; Index: Integer;
      Rect: TRect; State: TOwnerDrawState);
    procedure FormCreate(Sender: TObject);
  end;

[...]

procedure TForm1.FormCreate(Sender: TObject);
begin
  ListBox1.Count := 600000;
end;

procedure TForm1.ListBox1Data(Control: TWinControl; Index: Integer;
  var Data: string);
begin
  Data := IntToStr(Index) + ' listbox item number';
end;

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
begin
  // just simple drawing to be able to clearly see the items
  if odSelected in State then begin
    ListBox1.Canvas.Brush.Color := clHighlight;
    ListBox1.Canvas.Font.Color := clHighlightText;
  end;
  ListBox1.Canvas.FillRect(Rect);
  ListBox1.Canvas.TextOut(Rect.Left + 2, Rect.Top + 2, ListBox1.Items[Index]);
end;


To see the problem just thumb-track the scroll bar, you'll notice how the items are wrapped to begin from the start for every 65536 one as described by Arnaud in the comments to the question. And when you release the thumb, it will snap to an item in the top High(Word).


Below workaround intercepts WM_VSCROLL on the control and performs thumb and item positioning manually. The sample uses an interposer class for simplicity, but any other sub-classing method would do:

type
  TListBox = class(stdctrls.TListBox)
  private
    procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;
  end;

[...]

procedure TListBox.WMVScroll(var Msg: TWMVScroll);
var
  Info: TScrollInfo;
begin
  // do not intervene when themes are disabled
  if ThemeServices.ThemesEnabled then begin
    Msg.Result := 0;

    case Msg.ScrollCode of
      SB_THUMBPOSITION: Exit; // Nothing to do, thumb is already tracked
      SB_THUMBTRACK:
        begin
          ZeroMemory(@Info, SizeOf(Info));
          Info.cbSize := SizeOf(Info);
          Info.fMask := SIF_POS or SIF_TRACKPOS;
          if GetScrollInfo(Handle, SB_VERT, Info) and
              (Info.nTrackPos <> Info.nPos) then
            TopIndex := TopIndex + Info.nTrackPos - Info.nPos;
        end;
      else
        inherited;
    end;
  end else
    inherited;
end;

For a custom log viewer I wrote, I use a TListView in virtual mode, not a TListBox. Works great, no 32K limits, no need to fiddle with SetScrollInfo() at all. Just set the Item.Count and the rest is handled automatically. It even has an OnDataHint event that can be used to optimize data access by letting you load only the data that the TListView actually needs. You don't get that with a TListBox.

标签
易学教程内所有资源均来自网络或用户发布的内容,如有违反法律规定的内容欢迎反馈
该文章没有解决你所遇到的问题?点击提问,说说你的问题,让更多的人一起探讨吧!