ScrollBox представляет собой контейнер для визуальных компонент. Может иметь полосы прокрутки, с помощью которых можно добраться до любого элемента контейнера. Прокрутка осуществляется только с помощью ScrollBar’ов. На колесо мыши не реагирует. Перетаскивать содержимое мышью не умеет. Популярностью не пользуется.
Мне нужно приложение, в котором смог бы протестировать различные эффекты Direct2D. Интерфейсно хочу сделать два масштабируемых поля, в левом оригинал картинки, в правом — результат работы эффектов. В центре планирую разместить панель для настройки эффектов.
Помимо масштаба, левое и правое поля должны быть синхронизированы. И масштаб, и прокрутка должны осуществляться колесом мыши. Также, при захвате поля мышкой, с последующим перетаскиванием, должен быть адекватный скроллинг изображения.
Левая, правая и центральная панели — это ScrollBox’ы. Потому что, без дополнительных компонент, это единственный в Delphi подходящий вариант.
Прокрутка колесом мыши
Это просто
Обрабатываем событие формы OnMouseWheel. Почему не событие самого ScrollBox? Потому что до ScrollBox оно может не дойти, т.к. его могут перехватить другие компоненты, или форма решит, что ScrollBox’у это событие не надо.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
procedure TFmMain.FormMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); var sbx: TScrollBox; begin // 1. Поиск других компонент под курсором // 2. Определить, что под курсором ScrollBox sbx := TScrollBox(GetMouseControl(Self, TScrollBox, MousePos)); if not Assigned(sbx) then Exit; // 3. Подготовительные операции try if (ssCtrl in Shift) and Assigned(pbx) then begin // 4. С нажатым Ctrl - масштабирование end else if (ssShift in Shift) then // Горизонтальная прокрутка с нажатым Shift sbx.HorzScrollBar.Position := sbx.HorzScrollBar.Position - Sign(WheelDelta)*CSCROLL_DELTA else // Вертикальная прокрутка sbx.VertScrollBar.Position := sbx.VertScrollBar.Position - Sign(WheelDelta)*CSCROLL_DELTA; finally // Сообщаем, что событие обработано, остальным не рассылать Handled := True; // 5. Пост-операции end; end; |
Как видим, фокус в том, что мы просто либо увеличиваем, либо уменьшаем свойство Position соответствующего ScrollBar’а в зависимости от знака WheelDelta. Для определения компонента по координатам мыши пишем функцию GetMouseControl.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
function GetMouseControl(const AOwner: TComponent; AClass: TControlClass; const MousePos: TPoint): TControl; var i: Integer; c: TControl; begin Result := nil; if not Assigned(AOwner) then Exit; if not Assigned(AClass) then AClass := TControl; for i := AOwner.ComponentCount-1 downto 0 do begin if (AOwner.Components[i] is AClass) then begin c := TControl(AOwner.Components[i]); if Assigned(c.Parent) and (IsWindowVisible(c.Parent.Handle)) then Result := MouseInControl(c, MousePos); if Assigned(Result) then Exit; end; end; end; |
Функция пробегает по всем дочерним компонентам AOwner. Если компонент удовлетворяет классу AClass и присутствует на экране, проверяется вхождение точки в прямоугольник BoundsRect. Видимость проверяется функцией WinApi.IsWindowVisible. Например, если элемент находится на странице PageControl, которая в данный момент неактивна, IsWindowVisible вернет FALSE.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
function MouseInControl(const AControl: TControl; const AScreenPos: TPoint): TControl; var rct: TRect; pnt: TPoint; begin Result := nil; if (not Assigned(AControl)) then Exit; if not AControl.Visible then Exit; if Assigned(AControl.Parent) then begin pnt := AControl.Parent.ScreenToClient(AScreenPos); rct := AControl.BoundsRect; end else begin pnt := AControl.ScreenToClient(AScreenPos); rct := AControl.ClientRect; end; if PtInRect(rct,pnt) then Result := AControl; end; |
Почему BoundsRect. Если будем проверять вхождение по ClientRect, правый и нижний ScrollBar’ы не будут определены. В этом случае, вращая колесо мыши на полосе прокрутке, реакции не будет. Что выглядит для пользователя крайне непривычно, удивительно и ошибочно.
Это непросто
Выше приведен абсолютно рабочий код. Но есть существенный недостаток. Все компоненты, находящиеся на ScrollBox’е и которые хотели бы принимать колесо мыши, его не получат. Это означает, что TMemo, TRichEdit, TListBox, TStringGrid и прочие, реакция которых на прокрутку колесом привычна и естественна, будут глухи.
Очевидно, надо искать любой TControl по координате мыши, и анализировать его. Как правило, в конкретном проекте таких особых случаев не так много. Но, между тем, каждый такой случай уникален. Если заняться написанием класса продвинутого TScrollBox, необходимо будет добавить соответствующее событие, говорящее ScrollBox’у, реагировать ему на колесо или нет.
Попытаюсь дать небольшое приближение к «общему» случаю, которое не рекомендую использовать всегда и везде. В каждом отдельном случае — свой подход.
В листинге FormMouseWheel есть комментарий «1. Поиск других компонент под курсором». Допишем под ним следующее:
|
1 2 3 4 5 6 7 8 |
// 1. Поиск других компонент под курсором ctr := TWinControl(GetMouseControl(Self, TWinControl, MousePos)); if Assigned(ctr) and (not (ctr is TScrollBox)) then begin if CheckVertScrollBarPossible(ctr, WheelDelta>0) then Exit; end; |
Предполагаем, что интересуют только TWinControl. Конечно, в реальности могут интересовать и все TControl. На колесо мыши кто только не реагирует. Но сейчас ограничимся TWinControl.
Как видно, интересуют все TWinControl, кроме TScrollBox. Потому что обработкой ScrollBox’а занимается весь последующий в листинге код.
Функция CheckVertScrollBarPossible возвращает факт того, что событие колеса должно уйти компоненту ctr. Определять этот факт будем наличием у ctr вертикального ScrollBar’а.
|
1 2 3 4 5 6 7 8 9 10 11 |
function HasVertScrollBar(AHandle: HWND; var APos, AMax: Integer): Boolean; var sInfo: SCROLLINFO; begin ZeroMemory(@sInfo, SizeOf(sInfo)); sInfo.cbSize := SizeOf(sInfo); sInfo.fMask := SIF_ALL; Result := GetScrollInfo(AHandle, SB_VERT, sInfo); APos := sInfo.nPos; AMax := sInfo.nMax - sInfo.nPage; end; |
Функция, определяющая необходимость отправки события колеса в ctr:
|
1 2 3 4 5 6 7 8 9 |
function CheckVertScrollBarPossible(const AControl: TWinControl; const AUP: Boolean): Boolean; var wPos, wMax: Integer; begin Result := HasVertScrollBar(AControl.Handle, wPos, wMax) and (wMax>=0); if not Result then Exit; end; |
Теперь, если прокрутка осуществляется над компонентом, который имеет вертикальный ScrollBar, прокрутки в ScrollBox’е не будет. Будет прокрутка внутри этого компонента.
Но это не очень удобно. Вот бы сделать, как в браузере. Если крутим вверх, прокрутка в текстовом поле происходит до тех пор, пока ползунок не упрется в верхнюю часть, а далее уже прокручивается основное поле. Аналогично с прокруткой вниз.
Проблема в том, что нет какого-то одного универсального способа определить достижение ползунком максимума и минимума. В разных классах, определять факт того, что ползунок достиг верха или низа, надо по разному.
Прокрутка TCustomMemo
Можно было бы даже TCustomEdit, но тут на самом деле без привязки к конкретному классу. Метод покрывает также и TCustomListBox, и ряд других классов.
Допишем в конец CheckVertScrollBarPossible следующее:
|
1 2 3 |
Result := ((wPos < 1) and (not AUP)) or ((wMax-wPos < 0) and (AUP)) or ((wPos > 1) and (wPos< wMax)); |
В примере по ссылке в конце статьи на вкладках Brightness и Sharpen расположены TMemo и TListBox соответственно. Если уменьшить размер окна по вертикали так, чтобы появились полосы прокрутки у ScrollBox’ов, можно посмотреть, как себя ведут компоненты.
Если текст слишком мал для прокрутки, событие колеса уходит в ScrollBox, без захода в этот компонент.
Прокрутка TCustomRichEdit
Но на TRichEdit этот фокус действует не всегда. Если текст большой, все работает. Но если текст мал и полосы прокрутки нет, скроллинг вниз работает нормально, а при скроллинге вверх прокрутка ScrollBox’а не работает, пока мышь над RichEdit . Чуть модифицируем функцию CheckVertScrollBarPossible:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 |
if AControl is TCustomRichEdit then begin // При тексте чуть большем высоты элемента, RichEdit может отказаться // скролировать до нулевой позиции, дескать, и так видно. Поэтому, // перехода в скролбокс не произойдет Result := (wMax>=wPos) and (((wPos <= 1) and (not AUP)) or ((wMax-wPos <= 0) and (AUP)) or ((wPos > 1) and (wPos < wMax))); end else Result := ((wPos < 1) and (not AUP)) or ((wMax-wPos < 0) and (AUP)) or ((wPos > 1) and (wPos< wMax)); |
Код ведет себя хорошо и при малом тексте. Есть небольшой глюк RichEdit’а, он описан в комментарии.
Прокрутка TCustomGrid
Компонент безусловно полезный. Но по отношению к событию колеса ведет себя гадко. Как вылечить, поговорим чуть позже. Пока продолжим модифицировать CheckVertScrollBarPossible. Полный текст:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 |
function CheckVertScrollBarPossible(const AControl: TWinControl; const AUP: Boolean): Boolean; var wPos, wMax: Integer; begin Result := HasVertScrollBar(AControl.Handle, wPos, wMax) and (wMax>=0); if not Result then Exit; if AControl is TCustomGrid then begin // Если в гриде нет вертикального скролла, // Result будет FALSE // в отличие от RichEdit, у которого он есть всегда, // видим он или нет with TMyCustomGrid(AControl) do begin // Если грид не под фокусом дергаем св-во TopRow // и анализируем на предмет достижения видимого // верха-низа if not Focused then begin if AUP and (TopRow > FixedRows) then TopRow := TopRow-1; if (not AUP) and (TopRow + VisibleRowCount < RowCount) then TopRow := TopRow+1; Result := (not AUP and (TopRow = FixedRows)) or (AUP and (TopRow = RowCount-1)) or ((TopRow > FixedRows) and (TopRow + VisibleRowCount < RowCount-1)); end else // Если под фокусом анализируем Row Result := ((not AUP) and (Row = FixedRows)) or ((AUP) and (Row = RowCount-1)) or ((Row > FixedRows) and (Row < RowCount-1)); end; end else if AControl is TCustomRichEdit then begin // При тексте чуть большем высоты элемента, RichEdit может отказаться // скролировать до нулевой позиции, дескать, и так видно. Поэтому, // перехода в скроллбокс не произойдет Result := (wMax>=wPos) and (((wPos <= 1) and (not AUP)) or ((wMax-wPos <= 0) and (AUP)) or ((wPos > 1) and (wPos < wMax))); end else Result := ((wPos < 1) and (not AUP)) or ((wMax-wPos < 0) and (AUP)) or ((wPos > 1) and (wPos< wMax)); end; |
Предложенные решения ни в коей мере не претендуют на универсальность. Каждый случай, как выше отмечалось, уникален и требует персонального подхода. Здесь представлены, просто как пример. Набор классов не полон. Решение для грида, например, рассчитано на его стандартное поведение. Но с гридом можно делать просто сказочные вещи.
Лечить «гадкое» поведение TCustomGrid
Наследники этого класса и ряд других «эгоистов» ведут себя с колесом мыши следующим образом. Если фокус на экземпляре, то где бы мышь не находилась, событие колеса будет приходить в этот экземпляр. Т.е. мышь у меня вообще на другом мониторе, а прокрутка происходит в гриде на этом экране.
В том случае, когда фокус на гриде, событие OnMouseWheel у формы происходить не будет. Как быть?
Можно повеситься на событие WM_MOUSEWHEEL. Прописать и обработать в форме:
|
1 |
procedure WMMouseWheel(var Message: TWMMouseWheel); message WM_MOUSEWHEEL; |
Но за нас это уже сделали разработчики Delphi, поэтому переопределяем следующий метод:
|
1 2 |
protected procedure MouseWheelHandler(var Message: TMessage); override; |
Он вызывается как раз из обработчика события WM_MOUSEWHEEL с уже сформированным типом TCMMouseWheel.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 |
procedure TFmMain.MouseWheelHandler(var Message: TMessage); var msg: TCMMouseWheel; Handled: Boolean; begin Handled := False; msg := TCMMouseWheel(Message); msg.ShiftState := GetShiftState(msg.ShiftState); FormMouseWheel(Self, msg.ShiftState, msg.WheelDelta, Point(msg.XPos, msg.YPos), Handled); if not Handled then inherited; end; |
Что происходит. Происходит вызов ранее написанного обработчика события OnMouseWheel. И если обработчик не заявил свои права на колесо мыши ( not Handled ) обработка колеса идет дальше. Иначе, никто это сообщение больше не получит. Это означает, что даже при наличии фокуса на гриде, если обработчик решил, что событие его, в грид колесо не уйдет.
Чтобы не вызывать обработчик дважды, в FormCreate обнулим событие:
|
1 |
OnMouseWheel := nil; |
Есть неприятность, что msg.ShiftState содержит элементы множества, не соответствующие действительности. Shift не нажат, а в msg.ShiftState содержится ssShift. Поэтому происходит небольшая коррекция ShiftState на основании реально нажатых клавиш:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
// Нажат Ctrl function CtrlDown : Boolean; var State : TKeyboardState; begin GetKeyboardState(State); Result := ((State[vk_Control] and 128) <> 0); end; // Нажат Shift function ShiftDown : Boolean; var State : TKeyboardState; begin GetKeyboardState(State); Result := ((State[VK_SHIFT] and 128) <> 0); end; // Нажат Alt function AltDown : Boolean; var State : TKeyboardState; begin GetKeyboardState(State); Result := ((State[VK_MENU] and 128) <> 0); end; // Коррекция AShiftState (Ctrl/Shift/Alt) function GetShiftState(const AShiftState: TShiftState): TShiftState; begin Result := AShiftState; if CtrlDown then Result := Result + [ssCtrl] else Result := Result - [ssCtrl]; if ShiftDown then Result := Result + [ssShift] else Result := Result - [ssShift]; if not AltDown then Result := Result + [ssAlt] else Result := Result - [ssAlt]; end; |
Подведем итоги
При анализе компонента под мышью берем BoundsRect и приводим экранные координаты мыши в систему координат родителя:Parent.ScreenToClient(MousePos)Иначе ScrollBar’ы у ScrollBox’а останутся за бортом и колесо мыши на них действовать не будет. |
Для скроллинга достаточно изменить свойство VertScrollBar.Position на какую то фиксированную величину. Отрицательный WheelDelta означает, что надо двигаться вниз. Положительный — вверх. sbx.VertScrollBar.Position := sbx.VertScrollBar.Position - Sign(WheelDelta)*CSCROLL_DELTA;Проверку на отрицательность или превышение Range делать не надо, все будет сделано автоматически. |
| Для «отлова» события колеса надо использовать событие OnMouseWheel формы, либо переопределять метод MouseWheelHandler. Первый способ имеет смысл использовать, когда гриды и прочие деревья не планируются. Второй способ, когда требуется отловить событие до гридов, и не пустить к ним это событие. Если этот второй способ по каким-то причинам (мало ли) не сработает, надо вешаться сразу на WM_MOUSEWHEEL. |
| При анализе компонентов на ScrollBox’е на предмет стоит или нет пускать в них событие колеса, надо учитывать уникальную специфику текущего проекта. Предложенный выше способ не панацея, потому что, допустим, TTrackBar вертикального ScrollBar’а не имеет, а вот колесо мыши ему позарез надо. Поэтому легче и быстрее, без «универсальностей», обработать каждый конкретный случай. |
Масштабирование
Масштабировать ScrolBox’ы с элементами управления не будем. Это можно сделать, принцип точно такой же, как представленный ниже, но здесь это совершенно ни к чему.
Для отображения картинок использую TPaintBox. Под масштабированием понимаю расчет размеров экземпляров TPaintBox в зависимости от коэффициента FZoom. Превышение размеров экземпляров клиентской области несущего ScrollBox’а приведет к появлению полос прокрутки. Если расчетные размеры становятся меньше клиентской области, устанавливаю в пайнтбоксы размеры клиентской области, но внутри рисую уменьшенную копию изображения с выравниванием по центру.
Расчет размеров происходит следующим образом.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
procedure ResizePaintBox(const AImage: TGraphic; const ABox: TPaintBox; const AZoom: Single = 1.0; const AWidth: Integer = -1; const AHeight: Integer = -1); var rct: TRectF; sbx: TScrollBox; w,h: Integer; begin rct := VRectF(ABox.Parent.BoundsRect); if AWidth > 0 then rct.Width := AWidth; if AHeight > 0 then rct.Height := AHeight; rct := GetImageZoomRect(AImage, rct, AZoom); h := 0; if (ABox.Parent is TScrollBox) then begin sbx := TScrollBox(ABox.Parent); if sbx.BorderStyle <> bsNone then h := 4; end; if AWidth > 0 then w := AWidth - h else w := ABox.Parent.Width - h; if AHeight > 0 then h := AHeight - h else h := ABox.Parent.Height - h; ABox.Tag := ABox.Tag+1; try ABox.SetBounds(ABox.Left, ABox.Top, Max(w, Round(rct.Width)),Max(h, Round(rct.Height))); finally ABox.Tag := ABox.Tag-1; if Assigned(ABox.OnPaint) then ABox.OnPaint(ABox); end; end; |
Расчет пропорционального прямоугольника изображения с учетом масштаба происходит так:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 |
function GetImageZoomRect(const AImage: TGraphic; const ARect: TRectF; const AZoom: Single = 1.0): TRectF; begin if not Assigned(AImage) then Result := ARect else begin Result := RectF(0,0, AImage.Width, AImage.Height); Result := GetProportRect(Result, ARect.Width* AZoom, ARect.Height* AZoom); Result := CenterInRect(ARect, Result); end; end; |
Остальные функции можно посмотреть в модуле IP76.DrawUtils.
Осталось кое что дописать в FormMouseWheel. Масштаб должен происходить от точки курсора. Полный текст обработчика:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 |
procedure TFmMain.FormMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); var pnt: TPoint; bet: TPointF; rct: TRect; sbx: TScrollBox; pbx: TPaintBox; ctr: TWinControl; begin // 1. Поиск других компонент под курсором ctr := TWinControl(GetMouseControl(Self, TWinControl, MousePos)); if Assigned(ctr) and (not (ctr is TScrollBox)) then begin if CheckVertScrollBarPossible(ctr, WheelDelta>0) then Exit; end; // 2. Определить, что под курсором ScrollBox if ctr is TScrollBox then sbx := ctr as TScrollBox else sbx := TScrollBox(GetMouseControl(Self, TScrollBox, MousePos)); if not Assigned(sbx) then Exit; // 3. Подготовительные операции pbx := TPaintBox(GetParentChild(sbx, TPaintBox)); // Если Tag <> 0 отрисовки не будет pbLeft.Tag := pbLeft.Tag + 1; pb.Tag := pb.Tag + 1; try if (ssCtrl in Shift) and Assigned(pbx) then begin // 4. С нажатым Ctrl - масштабирование rct := pbx.ClientRect; if (rct.Width < 1) or (rct.Height < 1) then Exit; // Посчитать коэффициенты смещения от левого и верхнего краев pnt := sbx.ScreenToClient(MousePos); bet.X := (sbx.HorzScrollBar.Position + pnt.X)/rct.Width; bet.Y := (sbx.VertScrollBar.Position + pnt.Y)/rct.Height; // Посчитать коэффициент масштаба FZoom := FZoom + Sign(WheelDelta)*0.05; if FZoom < 0.2 then FZoom := 0.2; if FZoom > 5 then FZoom := 5; // Изменить размеры пайнтбоксов ResizePaintBoxes; // Посчитать новые смещения слева и сверху rct := pbx.ClientRect; bet.x := bet.X * rct.Width - pnt.X; bet.y := bet.Y * rct.Height - pnt.Y; // Назначить позиции sbx.HorzScrollBar.Position := Round(bet.x); sbx.VertScrollBar.Position := Round(bet.y); end else if (ssShift in Shift) then // Горизонтальная прокрутка с нажатым Shift sbx.HorzScrollBar.Position := sbx.HorzScrollBar.Position - Sign(WheelDelta)*CSCROLL_DELTA else // Вертикальная прокрутка sbx.VertScrollBar.Position := sbx.VertScrollBar.Position - Sign(WheelDelta)*CSCROLL_DELTA; finally chbSynchronizePositionClick(sbx); // Сообщить, что событие обработано, остальным не рассылать Handled := True; // Отрисовать в любом случае pbLeft.Tag := 0; pb.Tag := 0; // Если ScrollBox не центральный перерисовать // левый и правый ScrollBox'ы if not IsParentForControl(sbx, pnlClient) then begin sbxLeft.Refresh; sbxRight.Refresh; end; end; end; |
В силу целочисленности вычислений все равно будет небольшая погрешность. Но точку держит. Работает, когда размеры пайнтбоксов станут больше клиентской области родителя.
В коде встретилась такая запись:
|
1 |
chbSynchronizePositionClick(sbx); |
Это обработчик события OnClick на чекбоксе, отвечающего за синхронизацию ScrollBox’ов.
Синхронизация ScrollBox’ов
Идея заключается в том, что перемещая или масштабируя один ScrollBox, второй автоматически повторял за первым и масштаб и позицию. Для этого нужно всего-то выставить свойства Position соответствующих ScrollBar’ов в одинаковые значения. Масштаб у нас и так для обоих одинаков.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
procedure TFmMain.chbSynchronizePositionClick(Sender: TObject); var pbx: TPaintBox; begin TrackBar1.Tag := 1; try TrackBar1.Position := Round(FZoom * 10); finally TrackBar1.Tag := 0; end; if not chbSynchronizePosition.Checked then exit; if Sender = sbxLeft then pbx := pb else pbx := pbLeft; pbx.Tag := pbx.Tag + 1; try if Sender = sbxLeft then begin sbxRight.VertScrollBar.Position := sbxLeft.VertScrollBar.Position; sbxRight.HorzScrollBar.Position := sbxLeft.HorzScrollBar.Position; end else begin sbxLeft.VertScrollBar.Position := sbxRight.VertScrollBar.Position; sbxLeft.HorzScrollBar.Position := sbxRight.HorzScrollBar.Position; end; finally pbx.Tag := pbx.Tag - 1; if Assigned(pbx.OnPaint) then pbx.OnPaint(pbx); end; end; |
TrackBar отвечает за отображение и изменение текущего масштаба. Обработчик события вызывается во всех местах, где происходит смена позиции. Есть нюанс. Когда позиция ползунка в ScrollBar’е меняется мышью, то оказывается, что нет никакого события, об этом сигнализирующего.
Поэтому поступаем следующим образом. Пишем два метода:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 |
procedure TFmMain.LeftWindowProc(var Message: TMessage); begin if (Message.Msg = WM_VSCROLL) or (Message.Msg = WM_HSCROLL) then chbSynchronizePositionClick(sbxLeft); FLeftWindowProc(Message); end; procedure TFmMain.RightWindowProc(var Message: TMessage); begin if (Message.Msg = WM_VSCROLL) or (Message.Msg = WM_HSCROLL) then chbSynchronizePositionClick(sbxRight); FRightWindowProc(Message); end; |
В форме объявляем поля:
|
1 2 3 |
private FLeftWindowProc: TWndMethod; FRightWindowProc: TWndMethod; |
В обработчике события OnCreate формы пишем следующее:
|
1 2 |
FLeftWindowProc := SetWindowProc(sbxLeft,LeftWindowProc); FRightWindowProc := SetWindowProc(sbxRight,RightWindowProc); |
где
|
1 2 3 4 5 6 |
function SetWindowProc(const AControl: TControl; const ANewMethod: TWndMethod): TWndMethod; begin Result := AControl.WindowProc; AControl.WindowProc := ANewMethod; end; |
Теперь при смене позиции в ScrollBar’ах будет также происходить синхронизация между ScrollBox’ами.
Перетаскивание
В любом нормальном image viewer’е есть возможность ухватиться мышкой за изображение и «потаскать» его по полю. Чем мы хуже. Обрабатываем три события на PaintBox’ах OnMouseDown, OnMouseMove, OnMouseUp:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 |
procedure TFmMain.pbLeftMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin FMouseDown := (Button = mbLeft) and (Sender is TPaintBox); if FMouseDown then begin FMousePoint := Point(X,Y); FMousePoint := TControl(Sender).ClientToScreen(FMousePoint); end; end; procedure TFmMain.pbLeftMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); var pnt: TPoint; pbx: TPaintBox; sbx: TScrollBox; dx,dy: Integer; begin if not FMouseDown then Exit; if (Sender is TControl) and (TControl(Sender).Parent is TScrollBox) then sbx := TScrollBox(TControl(Sender).Parent) else Exit; pbx := TPaintBox(GetParentChild(sbx, TPaintBox)); if Assigned(pbx) then pbx.Tag := pbx.Tag+1; try Screen.Cursor := crDrag; pnt := Point(X,Y); pnt := TControl(Sender).ClientToScreen(pnt); dx := pnt.X - FMousePoint.X; dy := pnt.y - FMousePoint.y; sbx.VertScrollBar.Position := sbx.VertScrollBar.Position - dy; sbx.HorzScrollBar.Position := sbx.HorzScrollBar.Position - dx; FMousePoint := pnt; chbSynchronizePositionClick(sbx); finally if Assigned(pbx) then pbx.Tag := pbx.Tag-1; sbx.Refresh; end; end; procedure TFmMain.pbLeftMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin FMouseDown := False; Screen.Cursor := crDefault; end; |
Это обработчики и для левого, и для правого PaintBox’ов Нетрудно заметить, что обращений к конкретным экземплярам внутри не происходит. Собственно, комментировать тут нечего. Код очень небольшой.
Полезное про ScrollBox
В стандартном варианте ScrollBox при перетаскивании ползунков в ScrollBar’е ведет себя непривлекательно — перемещение происходит только при отпускании мыши. Хотелось бы видеть перемещение непосредственно при перетаскивании ползунка.
За это отвечает свойство TControlScrollBar.Tracking: Boolean. Если установлен в TRUE, перемещение содержимого ScrollBox будет происходить немедленно.
Свойства TControlScrollBar
| ButtonSize Определяет размер кнопки на полосе прокрутки. |
| Color Задает цвет полосы прокрутки. |
| Increment Определяет, насколько позиций перемещается отображение, когда пользователь щелкает одну из маленьких конечных стрелок на полосе прокрутки. Примечание. Не используйте свойство Increment, если Smooth имеет значение true. Когда Smooth имеет значение true, каждый раз, когда изменяется диапазон или видимость полосы прокрутки, значение Increment динамически пересчитывается. |
| Kind Указывает, является ли полоса прокрутки горизонтальной или вертикальной. |
| Margin Определяет, когда создается полоса прокрутки. Определяет минимальное количество пикселей, которое должно отделять каждый элемент управления от края элемента управления, использующего полосу прокрутки. Во время выполнения, когда дочерний элемент управления находится меньше, чем Margin пикселей от края и для параметра Visible установлено значение true, появляется полоса прокрутки. |
| ParentColor Используйте ParentColor, чтобы указать, что полоса прокрутки всегда должна отражать цвет выделения кнопки Windows |
| Position Определяет позицию формы при прокрутки. В случае PaintBox’а это будет либо его Top, либо Left, взятые по модулю. |
| Range Определяет, насколько форма может переместиться. В случае PaintBox’а это будет либо его высота, либо ширина. |
| ScrollPos Возвращает позицию полосы прокрутки. Только для чтения. |
| Size Задает размер полосы прокрутки. |
| Smooth Обеспечивает плавную прокрутку с автоматической настройкой инкремента и страницы |
| Style Задает стиль полосы прокрутки. |
| ThumbSize Определяет размер ползунка полосы прокрутки. |
| Tracking Определяет, будет ли форма перемещаться немедленно или только после отпускания кнопки мыши |
| Visible Определяет, будет ли видна полоса прокрутки. |
| IsScrollBarVisible Видна ли полоса прокрутки. Только для чтения. |
Пару свойств ScrollBar’ов полезно устанавливать в TRUE всегда, поэтому оформлено в виде процедуры, которую имеет смысл запускать в FormCreate:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
procedure SetScrollBoxesSmoothTracking(const AOwner: TComponent); var i: Integer; begin for i := 0 to AOwner.ComponentCount - 1 do begin if AOwner.Components[i] is TScrollBox then with TScrollBox(AOwner.Components[i]) do begin VertScrollBar.Smooth := True; VertScrollBar.Tracking := True; HorzScrollBar.Smooth := True; HorzScrollBar.Tracking := True; end; end; end; |
Баги
Anchors не нужен
Работая со ScrollBox’ом, как с панелью инструментов, велик соблазн установить для элементов редактирования свойство Anchors в [akLeft,akTop,akRight]. Когда появляется полоса прокрутки, элементы автоматически меняют правую границу, элемент становится уже. Когда полоса исчезает, элементы «расширяются» до нужного размера.
На рис.1. видим нормальное поведение компонент. Они «сузились» по размеру клиентской области.
Но если сейчас максимизируем окно, и если ползунок ScrollBar’а смещен, полоса прокрутки пропадет, но компоненты не растянутся по ширине клиентской области. Вернув окно в нормальное состояние, видим, что компоненты намертво уменьшились. И так будет происходить до тех пор, пока не исчезнут совсем.
Поэтому предлагается следующий фрагмент в обработчике события формы OnResize.
|
1 2 3 4 5 6 7 8 9 10 11 |
for i := 0 to ComponentCount - 1 do begin c := Components[i]; if (c is TControl) and (Tcontrol(c).Parent is TScrollBox) and IsParentForControl(TControl(c), pnlClient) then with TControl(c) do begin Anchors := Anchors - [akRight]; Width := TControl(c).Parent.ClientWidth - Left - 3; end; end; |
Он работает и на максимизацию, и на нормализацию. Видим, что происходит насильственное убирание выравнивания по правому краю:
|
1 |
Anchors := Anchors - [akRight] |
Моргает при изменении размеров окна
Особенно это заметно, если выбрать тему. Тема притормаживает отрисовку, поэтому промаргивание начинает раздражать. Баг может быть связан с тем, что для левой, правой и центральной панелей выбрано выравнивание Align <> alNone.
Поэтому в OnCreate формы сбросим выравнивание:
|
1 2 3 |
pnlLeft.Align := alNone; pnlRight.Align := alNone; pnlClient.Align := alNone; |
А в событии OnResize формы посчитаем размеры этих панелей:
|
1 2 3 4 5 |
// 1. Расчет новых размеров w := (ClientWidth - pnlClient.Width) div 2; h := pnlLeft.Parent.ClientHeight - pnlTop.Height - pnlBottom.Height; l := pnlLeft.Parent.ClientRect.Left; |
Далее назначим эти размеры:
|
1 2 3 4 5 6 |
// 3. Установка размеров и положения основных панелей pnlLeft.SetBounds(l, pnlTop.Height, w, h); pnlClient.SetBounds(pnlLeft.BoundsRect.Right, pnlLeft.Top, pnlClient.Width, h); pnlRight.SetBounds(pnlClient.BoundsRect.Right, pnlLeft.Top, w, h); |
Моргают полосы прокрутки при изменении размеров окна
При уменьшении размеров окна начинают моргать, т.е. появляться и пропадать полосы прокрутки. Предлагается сделать так. Все в том же OnResize формы, между 1. и 3. (см. комментарии в коде выше) вставим следующий код:
|
1 2 3 4 5 6 7 |
// 2. Изменить размеры PaintBox'ов под будущие размеры панелей if (w < pnlLeft.Width) or (h < pnlLeft.Height) then begin dw := sbxLeft.Width - (pnlLeft.Width-w); dh := sbxLeft.Height - (pnlLeft.Height-h); ResizePaintBoxes(dw,dh); end; |
После комментария 3. вставим еще один вызов:
|
1 |
ResizePaintBoxes; |
Сама процедура очень простая:
|
1 2 3 4 5 6 |
procedure TFmMain.ResizePaintBoxes(const AWidth: Integer = -1; const AHeight: Integer = -1); begin ResizePaintBox(GetCurrImage, pbLeft, FZoom, AWidth, AHeight); ResizePaintBox(GetCurrImage, pb, FZoom, AWidth, AHeight); end; |
Полностью код лучше посмотреть в исходниках по ссылке ниже.
Кракозяблы в Windows 7
Если запустим программу под Windows 7 увидим такое неприятное чудо:
На рис.3 пропали надписи на кнопках. Связано с тем, что шрифт, который использую для отображения символов Юникода, Segoe UI Symbol, в Windows 7 только появился и не настолько богат, как в Windows 10. Да и сам Юникод не был так разнообразен, как сейчас.
Лечением проблемы займемся в следующей статье. К ScrollBox’у эта тема не имеет никакого отношения.
Друзья, спасибо за внимание!
Надеюсь, материал был полезен.
В следующей статье будет рассмотрено, как TStyleHook и GDI+ могут помочь в разных «программно-жизненных» ситуациях.
Не пропустите, подписывайтесь на телегу.
Если есть вопросы, с удовольствием отвечу.
Возможно, многие ответы найдутся в исходниках. Из-за экономии места, частные случаи остались «за кадром». Приведенные в статье листинги показывает основу, суть, без дополнительных обработок ошибок. За подробностями лучше обратиться к исходникам.
Скачать
Исходники (Delphi XE 7-10) 202 Кб
Исполняемый файл 1.12 Мб
Роман, спасибо большое за статью!
Не поверишь, но не так давно столкнулся с похожей проблемой отлова колеса мыши и на скорую руку, в лоб и по-быстрому оно не решилось ) Зато теперь, благодаря тебе, решение практически найдено, осталось лишь адаптировать его под мою конкретную задачу.
Так что ещё ра благодарю, статья реально полезна.
Алексей, привет!
Даже не представляешь себе, как я рад, что материал оказался полезен )
Роман, благодарю! Пример пригодился в конкретной ситуации, где пришлось заставить дружить скроллбокс со скроллом мыши.
Не за что! Если есть вопросы, отвечу.
Шикарная статья. Очень пригодилась. 🙂
Спасибо! Очень рад )))
а как можно получить экранные координаты ползунка скроллбара?
Честно говоря, не знаю. Ни разу не требовалось. В WINAPI такой возможности не встречал. Можно сделать следующее:
1) Посчитать самому. Зная размер скроллбара, размеры стрелок сверху-снизу (для вертикального), можно вычислить размер области ползунка. Зная диапазон и текущую позицию, вычислить координаты;
2) Навесить ловушку, ну скажем, мышиную и посмотреть куда идут сообщения. Если ползунок имеет Handle, то получить размеры через GetWindowRect. Из ловушки можно получить и координаты;
3) Убрать скроллбар(если речь о скроллбоксе) и нарисовать самостоятельно.
Возможно, есть вообще очень простецкий способ, но я его не знаю.
Роман спасибо. Интересная и полезная статья, некоторые моменты не знал.
Не за что! Рад, что пригодилось )))
Роман жаль что больше нет материала с ная
Согласен, жаль ))) Скучаю по статьям. Материала море. Времени нет совсем. Возможно, весной что-то начнёт появляться.
Роман, а можно наложить твои красивые примеры линейные, на растр типа физической карты, на одном примере я что то подобное видел, но подложка, размытая, как будто верхнее изображение не полностью прозрачное.
А какие мои красивые примеры линейные имеются ввиду? Складывается ощущение, что говорится про наложение одного изображения на другое, но не хватает конкретики )))
Роман, а как сделать холст прозрачным
Холст нельзя сделать прозрачным. Можно заставить казаться прозрачным. Для этого нужно на холсте нарисовать всё то, что под (или за) холстом.
Если надо нарисовать что-то на карте, то вначале рисуем видимый прямоугольник карты, затем, поверх, это что-то.
ScrollBox при прокрутке автоматически перерисовывает клиентскую область со смещением соответственно величине прокрутки. Можно это как-то отключить?
Отключить свойствами нельзя.
Можно сделать потомка и там реализовать всю отрисовку. Все «скрытые» места открыты.
Либо, если опираться на текст статьи, заставить перерисовываться при каждом событии скрола.
Если на скроллбоксе много компонент и они начинают растягиваться «гармошкой» этот способ может помочь.
И, конечно, оптимизировать рисовку. В статье оптимизации не касался, но можно ведь не масштабировать на весь отзумленный прямоугольник, а только то, что будет видно.
Проблема в том, что смещение клиентской области при прокрутке не связана с PaintWindow и т.п. В предке скроллбокса TScrollingWinControl есть скрытый метод SetPosition, в котором используется FControl.ScrollBy. Он-то и «сдвигает» содержимое скроллбокса.
В общем, сделал свой компонент по типу TScrollingWinControl без использования ScrollBy
Bmp. Canvas. Brush. Color:=clWhite:
Bmp. Transparent := true:
Bmp. Transparent color :=clwhite:
Bmp. Canvas. FillRect(rct) :
Нижняя картинка видится, но При движении мыши происходит клонирование всего, что находится на верху,
Это практически ни о чем не говорящий кусок кода.
Сформулируйте словами, что вы хотите получить?
Я хочу получить прозрачную конву на которой я могу строить отрезки типа ваших, все я получаю, но когда я подключаю canvas. Fillrect(rct), при перемещении мыши у меня остаются на холсте копии курсора с координатами, табло, и построенные точки… Не происходит петерисовки видимо.
Везде, где мышь как-то меняет изображение — насильственная перерисовка.
Примерно что-то такое? Или что-то совсем другое?
D Роман вот что получается
Вот такая картинка
Могу предположить, что ситуация такая — есть Image1, в нём картинка.
Над Image1 допустим PaintBox.
Хочется нарисовать на PaintBox так, чтобы выглядело, как будто рисуем на картинке?
Тогда просто рисуем на PaintBox’е, без bmp.
Но надо ещё сделать следующее:
1) Поставить TPanel
2) Image1 и PaintBox1 переместить на эту панель
3) У панели уставноить свойство DoubleBuffered := True и ParentBackground := False
4) Просто нарисовать на канве PaintBox’а (листинг)
5) Все прямые вызовы обработчика отрисовки (типа pbPaint(pb)) заменить на легальный вызов «отрисуйся» (pb.Refresh)
Очень не советую думать, что так вы бережёте ресурсы. Это очень плохой путь.
Спасибо,этот вариант был он работает с Pb,можно и через DRAW, Вообще то красивее было бы по загрузке через файл.У вас очень все аккуратно и четко как у военного…..С наступающим мужским праздником
Ответ тут. Не хотел, чтобы комментарий на «нет» сошёл по ширине )))
по высоте не сошел