Как прокрутить TScrollbar с помощью колесика мыши?

Question

У меня есть TScrollBar с кодом в событии OnScroll.

Я хочу прокрутить его с помощью колеса мыши, но поворот колеса мыши не прокручивает полосу прокрутки и не вызывает событие OnScroll.

Есть идеи?

Answer 1

procedure TForm1.FormMouseWheel(Sender: TObject; Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
var
  I: Integer;
begin
  Handled := PtInRect(ScrollBox1.ClientRect, ScrollBox1.ScreenToClient(MousePos));
  if Handled then
    for I := 1 to Mouse.WheelScrollLines do
    try
      if WheelDelta > 0 then
        ScrollBox1.Perform(WM_VSCROLL, SB_LINEUP, 0)
      else
        ScrollBox1.Perform(WM_VSCROLL, SB_LINEDOWN, 0);
    finally
      ScrollBox1.Perform(WM_VSCROLL, SB_ENDSCROLL, 0);
    end;
end;

Answer 2

Компонент TScrollBar по умолчанию, по-видимому, не содержит событий OnMouseWheel *. Но вы можете просто назначить их следующим образом:

type
  TForm1 = class(TForm)
    ScrollBar1: TScrollBar;
    procedure FormCreate(Sender: TObject);
    procedure ScrollBar1Scroll(Sender: TObject; ScrollCode: TScrollCode;
      var ScrollPos: Integer);
  private
    procedure ScrollBarMouseWheel(Sender: TObject; Shift: TShiftState;
      WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
  end;

...

procedure TForm1.FormCreate(Sender: TObject);
begin
  ScrollBar1.OnMouseWheel := ScrollBarMouseWheel;
end;

procedure TForm1.ScrollBarMouseWheel(Sender: TObject; Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
var
  NewScrollPos: Integer;
begin
  NewScrollPos := ScrollBar1.Position - WheelDelta;
  //Trigger the OnScroll event:
  ScrollBar1.Scroll(scPosition, NewScrollPos);
  //Scroll the bar into the new position:
  ScrollBar1.Position := NewScrollPos;
  Handled := True;
end;

Вы можете реализовать это более креативно:

  if WheelDelta > 0 then
    NewScrollPos := ScrollBar1.Position - ScrollBar1.PageSize
  else
    NewScrollPos := ScrollBar1.Position + ScrollBar1.PageSize;

И вы можете вставить класс TScrollBar, чтобы предотвратить назначение события во время выполнения:

type
  TScrollBar = class(StdCtrls.TScrollBar)
  protected
    function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
      MousePos: TPoint): Boolean; override;
  end;

function TScrollBar.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
  MousePos: TPoint): Boolean;
var
  NewScrollPos: Integer;
begin
  NewScrollPos := Position - WheelDelta;
  Scroll(scPosition, NewScrollPos);
  Position := NewScrollPos;
  Result := True;
end;

Answer 3

слишком просто, просто увеличьте значение позиции.

procedure TForm1.FormMouseWheel(Sender: TObject; Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
begin
self.VertScrollBar.Position :=  self.VertScrollBar.Position + WheelDelta;
end;

Answer 4

procedure TForm1.FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
  MousePos: TPoint; var Handled: Boolean);
begin
  ScrollBox1.VertScrollBar.Position := ScrollBox1.VertScrollBar.Position + 20;
end;

procedure TForm1.FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
  MousePos: TPoint; var Handled: Boolean);
begin
  ScrollBox1.VertScrollBar.Position := ScrollBox1.VertScrollBar.Position - 20;
end;

Answer 5

Старый пост, но я нашел решение.Просто сделай

procedure TForm1.FormMouseWheel(Sender: TObject; Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
begin
  inherited;

  ScrollBox1.ScrollBy(WheelDelta, 0);
end;

У меня работает.

Answer 6

Не знаю, сильно ли это поможет, но вот как это сделать с TMemo.Полоса прокрутки должна была бы быть похожим процессом, если только не существует какого-то другого лучшего способа, чем версии Delphi, более поздние, чем у меня.

procedure TForm1.Memo1WindowProc(var msg: TMessage);
  var
    ticks: ShortInt;
    ScrollMsg: TWMVScroll;
  begin
    if msg.Msg = WM_MOUSEWHEEL then
      begin
        ScrollMsg.Msg := WM_VSCROLL;
        ticks := HiWord(msg.wparam);
        if ticks > 0 then
          ScrollMsg.ScrollCode := sb_LineUp
        else
          ScrollMsg.ScrollCode := sb_LineDown;
        ScrollMsg.Pos:=0;
        Memo1.Dispatch(ScrollMsg) ;
      end
    else
      OldMemo1(msg);
    end;

procedure TForm1.FormCreate(Sender: TObject);
 // save old window proc, assign mine.
  begin
    OldMemo1 := Memo1.WindowProc;
    Memo1.WindowProc := Memo1WindowProc;
  end;

HTH some.