mirror of
https://github.com/HeidiSQL/HeidiSQL.git
synced 2025-08-06 18:24:26 +08:00
938 lines
27 KiB
ObjectPascal
938 lines
27 KiB
ObjectPascal
unit VirtualTrees.StyleHooks;
|
|
|
|
// The contents of this file are subject to the Mozilla Public License
|
|
// Version 1.1 (the "License"); you may not use this file except in compliance
|
|
// with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/
|
|
//
|
|
// Alternatively, you may redistribute this library, use and/or modify it under the terms of the
|
|
// GNU Lesser General Public License as published by the Free Software Foundation;
|
|
// either version 2.1 of the License, or (at your option) any later version.
|
|
// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/.
|
|
//
|
|
// Software distributed under the License is distributed on an "AS IS" basis,
|
|
// WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the
|
|
// specific language governing rights and limitations under the License.
|
|
//
|
|
// The original code is VirtualTrees.pas, released September 30, 2000.
|
|
//
|
|
// The initial developer of the original code is digital publishing AG (Munich, Germany, www.digitalpublishing.de),
|
|
// written by Mike Lischke (public@soft-gems.net, www.soft-gems.net).
|
|
//
|
|
// Portions created by digital publishing AG are Copyright
|
|
// (C) 1999-2001 digital publishing AG. All Rights Reserved.
|
|
//----------------------------------------------------------------------------------------------------------------------
|
|
|
|
|
|
interface
|
|
|
|
{$WARN UNSAFE_TYPE OFF}
|
|
{$WARN UNSAFE_CAST OFF}
|
|
{$WARN UNSAFE_CODE OFF}
|
|
|
|
uses
|
|
Winapi.Windows,
|
|
Winapi.Messages,
|
|
Winapi.UxTheme,
|
|
|
|
System.Classes,
|
|
Vcl.Themes,
|
|
Vcl.Forms,
|
|
Vcl.Controls;
|
|
|
|
const
|
|
CM_UPDATE_VCLSTYLE_SCROLLBARS = CM_BASE + 2050;
|
|
|
|
type
|
|
// XE2+ VCL Style
|
|
TVclStyleScrollBarsHook = class(TScrollingStyleHook)
|
|
strict private type
|
|
{$REGION 'TVclStyleScrollBarWindow'}
|
|
TScrollWindow = class(TWinControl)
|
|
strict private
|
|
FStyleHook: TVclStyleScrollBarsHook;
|
|
FVertical: Boolean;
|
|
procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;
|
|
procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND;
|
|
procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
property StyleHook: TVclStyleScrollBarsHook read FStyleHook write FStyleHook;
|
|
property Vertical: Boolean read FVertical write FVertical;
|
|
end;
|
|
{$ENDREGION}
|
|
private
|
|
FHorzScrollWnd: TScrollWindow;
|
|
FLeftMouseButtonDown: Boolean;
|
|
FVertScrollWnd: TScrollWindow;
|
|
|
|
function NCMousePosToClient(const P: TPoint): TPoint;
|
|
|
|
procedure CMUpdateVclStyleScrollbars(var Msg: TMessage); message CM_UPDATE_VCLSTYLE_SCROLLBARS;
|
|
procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;
|
|
procedure WMKeyDown(var Msg: TMessage); message WM_KEYDOWN;
|
|
procedure WMKeyUp(var Msg: TMessage); message WM_KEYUP;
|
|
procedure WMLButtonDown(var Msg: TWMMouse); message WM_LBUTTONDOWN;
|
|
procedure WMLButtonUp(var Msg: TWMMouse); message WM_LBUTTONUP;
|
|
procedure WMNCLButtonDown(var Msg: TWMMouse); message WM_NCLBUTTONDOWN;
|
|
procedure WMNCMouseMove(var Msg: TWMMouse); message WM_NCMOUSEMOVE;
|
|
procedure WMNCLButtonUp(var Msg: TWMMouse); message WM_NCLBUTTONUP;
|
|
procedure WMNCPaint(var Msg: TMessage); message WM_NCPAINT;
|
|
procedure WMMouseMove(var Msg: TWMMouse); message WM_MOUSEMOVE;
|
|
procedure WMMouseWheel(var Msg: TMessage); message WM_MOUSEWHEEL;
|
|
procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;
|
|
procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;
|
|
procedure WMCaptureChanged(var Msg: TMessage); message WM_CAPTURECHANGED;
|
|
procedure WMNCLButtonDblClk(var Msg: TWMMouse); message WM_NCLBUTTONDBLCLK;
|
|
procedure WMSize(var Msg: TMessage); message WM_SIZE;
|
|
procedure WMMove(var Msg: TMessage); message WM_MOVE;
|
|
procedure WMPosChanged(var Msg: TMessage); message WM_WINDOWPOSCHANGED;
|
|
protected
|
|
procedure CalcScrollBarsRect; virtual;
|
|
procedure DrawHorzScrollBar(DC: HDC); virtual;
|
|
procedure DrawVertScrollBar(DC: HDC); virtual;
|
|
procedure MouseLeave; override;
|
|
procedure PaintScroll; override;
|
|
function PointInTreeHeader(const P: TPoint): Boolean;
|
|
procedure UpdateScroll;{$if CompilerVersion >= 34}override;{$ifend}
|
|
public
|
|
constructor Create(AControl: TWinControl); override;
|
|
destructor Destroy; override;
|
|
property HorzScrollRect;
|
|
property VertScrollRect;
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses
|
|
System.SysUtils,
|
|
System.Math,
|
|
System.Types,
|
|
Vcl.Graphics,
|
|
VirtualTrees;
|
|
|
|
type
|
|
TBaseVirtualTreeCracker = class(TBaseVirtualTree)
|
|
end;
|
|
|
|
|
|
// XE2+ VCL Style
|
|
{ TVclStyleScrollBarsHook }
|
|
|
|
procedure TVclStyleScrollBarsHook.CalcScrollBarsRect;
|
|
|
|
procedure CalcVerticalRects;
|
|
var
|
|
BarInfo: TScrollBarInfo;
|
|
Ret: BOOL;
|
|
begin
|
|
BarInfo.cbSize := SizeOf(BarInfo);
|
|
Ret := GetScrollBarInfo(Handle, Integer(OBJID_VSCROLL), BarInfo);
|
|
FVertScrollWnd.Visible := (seBorder in Control.StyleElements) and Ret and (not (STATE_SYSTEM_INVISIBLE and BarInfo.rgstate[0] <> 0));
|
|
FVertScrollWnd.Enabled := FVertScrollWnd.Visible and (not (STATE_SYSTEM_UNAVAILABLE and BarInfo.rgstate[0] <> 0));
|
|
end;
|
|
|
|
procedure CalcHorizontalRects;
|
|
var
|
|
BarInfo: TScrollBarInfo;
|
|
Ret: BOOL;
|
|
begin
|
|
BarInfo.cbSize := SizeOf(BarInfo);
|
|
Ret := GetScrollBarInfo(Handle, Integer(OBJID_HSCROLL), BarInfo);
|
|
FHorzScrollWnd.Visible := (seBorder in Control.StyleElements) and Ret and (not (STATE_SYSTEM_INVISIBLE and BarInfo.rgstate[0] <> 0));
|
|
FHorzScrollWnd.Enabled := FHorzScrollWnd.Visible and (not (STATE_SYSTEM_UNAVAILABLE and BarInfo.rgstate[0] <> 0));
|
|
end;
|
|
|
|
begin
|
|
CalcVerticalRects;
|
|
CalcHorizontalRects;
|
|
end;
|
|
|
|
constructor TVclStyleScrollBarsHook.Create(AControl: TWinControl);
|
|
begin
|
|
inherited;
|
|
FVertScrollWnd := TScrollWindow.CreateParented(GetParent(Control.Handle));
|
|
FVertScrollWnd.StyleHook := Self;
|
|
FVertScrollWnd.Vertical := True;
|
|
|
|
FHorzScrollWnd := TScrollWindow.CreateParented(GetParent(Control.Handle));
|
|
FHorzScrollWnd.StyleHook := Self;
|
|
|
|
VertSliderState := tsThumbBtnVertNormal;
|
|
VertUpState := tsArrowBtnUpNormal;
|
|
VertDownState := tsArrowBtnDownNormal;
|
|
HorzSliderState := tsThumbBtnHorzNormal;
|
|
HorzUpState := tsArrowBtnLeftNormal;
|
|
HorzDownState := tsArrowBtnRightNormal;
|
|
end;
|
|
|
|
destructor TVclStyleScrollBarsHook.Destroy;
|
|
begin
|
|
FVertScrollWnd.StyleHook := nil;
|
|
FreeAndNil(FVertScrollWnd);
|
|
FHorzScrollWnd.StyleHook := nil;
|
|
FreeAndNil(FHorzScrollWnd);
|
|
inherited;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.DrawHorzScrollBar(DC: HDC);
|
|
var
|
|
B: TBitmap;
|
|
Details: TThemedElementDetails;
|
|
R: TRect;
|
|
begin
|
|
if ((Handle = 0) or (DC = 0)) then
|
|
Exit;
|
|
|
|
if FHorzScrollWnd.Visible and StyleServices.Available and (seBorder in Control.StyleElements) then
|
|
begin
|
|
B := TBitmap.Create;
|
|
try
|
|
R := HorzScrollRect;
|
|
B.Width := R.Width;
|
|
B.Height := R.Height;
|
|
MoveWindowOrg(B.Canvas.Handle, -R.Left, -R.Top);
|
|
|
|
R.Left := HorzUpButtonRect.Right;
|
|
R.Right := HorzDownButtonRect.Left;
|
|
Details := StyleServices.GetElementDetails(tsUpperTrackHorzNormal);
|
|
StyleServices.DrawElement(B.Canvas.Handle, Details, R);
|
|
|
|
if FHorzScrollWnd.Enabled then
|
|
Details := StyleServices.GetElementDetails(HorzSliderState);
|
|
StyleServices.DrawElement(B.Canvas.Handle, Details, HorzSliderRect);
|
|
|
|
if FHorzScrollWnd.Enabled then
|
|
Details := StyleServices.GetElementDetails(HorzUpState)
|
|
else
|
|
Details := StyleServices.GetElementDetails(tsArrowBtnLeftDisabled);
|
|
StyleServices.DrawElement(B.Canvas.Handle, Details, HorzUpButtonRect);
|
|
|
|
if FHorzScrollWnd.Enabled then
|
|
Details := StyleServices.GetElementDetails(HorzDownState)
|
|
else
|
|
Details := StyleServices.GetElementDetails(tsArrowBtnRightDisabled);
|
|
StyleServices.DrawElement(B.Canvas.Handle, Details, HorzDownButtonRect);
|
|
|
|
R := HorzScrollRect;
|
|
MoveWindowOrg(B.Canvas.Handle, R.Left, R.Top);
|
|
BitBlt(DC, R.Left, R.Top, B.Width, B.Height, B.Canvas.Handle, 0, 0, SRCCOPY);
|
|
finally
|
|
B.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.DrawVertScrollBar(DC: HDC);
|
|
var
|
|
B: TBitmap;
|
|
Details: TThemedElementDetails;
|
|
R: TRect;
|
|
begin
|
|
if ((Handle = 0) or (DC = 0)) then
|
|
Exit;
|
|
|
|
if FVertScrollWnd.Visible and StyleServices.Available and (seBorder in Control.StyleElements) then
|
|
begin
|
|
B := TBitmap.Create;
|
|
try
|
|
R := VertScrollRect;
|
|
B.Width := R.Width;
|
|
B.Height := FVertScrollWnd.Height; // <> R.Height
|
|
MoveWindowOrg(B.Canvas.Handle, -R.Left, -R.Top);
|
|
|
|
R.Bottom := B.Height + R.Top;
|
|
Details := StyleServices.GetElementDetails(tsUpperTrackVertNormal);
|
|
StyleServices.DrawElement(B.Canvas.Handle, Details, R);
|
|
|
|
R.Top := VertUpButtonRect.Bottom;
|
|
R.Bottom := VertDownButtonRect.Top;
|
|
Details := StyleServices.GetElementDetails(tsUpperTrackVertNormal);
|
|
StyleServices.DrawElement(B.Canvas.Handle, Details, R);
|
|
|
|
if FVertScrollWnd.Enabled then
|
|
Details := StyleServices.GetElementDetails(VertSliderState);
|
|
StyleServices.DrawElement(B.Canvas.Handle, Details, VertSliderRect);
|
|
|
|
if FVertScrollWnd.Enabled then
|
|
Details := StyleServices.GetElementDetails(VertUpState)
|
|
else
|
|
Details := StyleServices.GetElementDetails(tsArrowBtnUpDisabled);
|
|
StyleServices.DrawElement(B.Canvas.Handle, Details, VertUpButtonRect);
|
|
|
|
if FVertScrollWnd.Enabled then
|
|
Details := StyleServices.GetElementDetails(VertDownState)
|
|
else
|
|
Details := StyleServices.GetElementDetails(tsArrowBtnDownDisabled);
|
|
StyleServices.DrawElement(B.Canvas.Handle, Details, VertDownButtonRect);
|
|
|
|
R := VertScrollRect;
|
|
MoveWindowOrg(B.Canvas.Handle, R.Left, R.Top);
|
|
BitBlt(DC, R.Left, R.Top, B.Width, B.Height, B.Canvas.Handle, 0, 0, SRCCOPY);
|
|
finally
|
|
B.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.MouseLeave;
|
|
begin
|
|
inherited;
|
|
if VertSliderState = tsThumbBtnVertHot then
|
|
VertSliderState := tsThumbBtnVertNormal;
|
|
|
|
if HorzSliderState = tsThumbBtnHorzHot then
|
|
HorzSliderState := tsThumbBtnHorzNormal;
|
|
|
|
if VertUpState = tsArrowBtnUpHot then
|
|
VertUpState := tsArrowBtnUpNormal;
|
|
|
|
if VertDownState = tsArrowBtnDownHot then
|
|
VertDownState := tsArrowBtnDownNormal;
|
|
|
|
if HorzUpState = tsArrowBtnLeftHot then
|
|
HorzUpState := tsArrowBtnLeftNormal;
|
|
|
|
if HorzDownState = tsArrowBtnRightHot then
|
|
HorzDownState := tsArrowBtnRightNormal;
|
|
|
|
PaintScroll;
|
|
end;
|
|
|
|
function TVclStyleScrollBarsHook.NCMousePosToClient(const P: TPoint): TPoint;
|
|
begin
|
|
Result := P;
|
|
ScreenToClient(Handle, Result);
|
|
if HasBorder then
|
|
begin
|
|
if HasClientEdge then
|
|
Result.Offset(2, 2)
|
|
else
|
|
Result.Offset(1, 1);
|
|
end;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.PaintScroll;
|
|
begin
|
|
if FVertScrollWnd.HandleAllocated then
|
|
begin
|
|
FVertScrollWnd.Repaint;
|
|
RedrawWindow(FVertScrollWnd.Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE); // Fixes issue #698
|
|
end;
|
|
if FHorzScrollWnd.HandleAllocated then
|
|
begin
|
|
FHorzScrollWnd.Repaint;
|
|
RedrawWindow(FHorzScrollWnd.Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE); // Fixes issue #698
|
|
end;
|
|
end;
|
|
|
|
function TVclStyleScrollBarsHook.PointInTreeHeader(const P: TPoint): Boolean;
|
|
begin
|
|
Result := TBaseVirtualTree(Control).Header.InHeader(P);
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.UpdateScroll;
|
|
var
|
|
R: TRect;
|
|
HeaderHeight: Integer;
|
|
PaddingSize: Integer;
|
|
BorderSize: Integer;
|
|
begin
|
|
// ScrollBarWindow Visible/Enabled Control
|
|
CalcScrollBarsRect;
|
|
|
|
HeaderHeight := 0;
|
|
if (hoVisible in TBaseVirtualTree(Control).Header.Options) then
|
|
Inc(HeaderHeight, TBaseVirtualTree(Control).Header.Height);
|
|
|
|
PaddingSize := TBaseVirtualTreeCracker(Control).BorderWidth;
|
|
if TBaseVirtualTreeCracker(Control).BevelKind <> bkNone then
|
|
begin
|
|
if TBaseVirtualTreeCracker(Control).BevelInner <> bvNone then
|
|
Inc(PaddingSize, TBaseVirtualTreeCracker(Control).BevelWidth);
|
|
if TBaseVirtualTreeCracker(Control).BevelOuter <> bvNone then
|
|
Inc(PaddingSize, TBaseVirtualTreeCracker(Control).BevelWidth);
|
|
end;
|
|
|
|
BorderSize := 0;
|
|
if HasBorder then
|
|
Inc(BorderSize, GetSystemMetrics(SM_CYEDGE));
|
|
|
|
// VertScrollBarWindow
|
|
if FVertScrollWnd.Visible then
|
|
begin
|
|
R := VertScrollRect;
|
|
if Control.UseRightToLeftScrollBar then
|
|
OffsetRect(R, -R.Left + BorderSize, 0);
|
|
|
|
ShowWindow(FVertScrollWnd.Handle, SW_SHOW);
|
|
SetWindowPos(FVertScrollWnd.Handle, HWND_TOP,
|
|
Control.Left + R.Left + PaddingSize,
|
|
Control.Top + R.Top + HeaderHeight + PaddingSize,
|
|
R.Width,
|
|
Control.Height - HeaderHeight - ((PaddingSize + BorderSize) * 2), // <> R.Height
|
|
SWP_SHOWWINDOW);
|
|
end else
|
|
ShowWindow(FVertScrollWnd.Handle, SW_HIDE);
|
|
|
|
// HorzScrollBarWindow
|
|
if FHorzScrollWnd.Visible then
|
|
begin
|
|
R := HorzScrollRect;
|
|
if Control.UseRightToLeftScrollBar then
|
|
OffsetRect(R, VertScrollRect.Width, 0);
|
|
|
|
ShowWindow(FHorzScrollWnd.Handle, SW_SHOW);
|
|
SetWindowPos(FHorzScrollWnd.Handle, HWND_TOP,
|
|
Control.Left + R.Left + PaddingSize,
|
|
Control.Top + R.Top + HeaderHeight + PaddingSize,
|
|
R.Width, R.Height, SWP_SHOWWINDOW);
|
|
end else
|
|
ShowWindow(FHorzScrollWnd.Handle, SW_HIDE);
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.WMCaptureChanged(var Msg: TMessage);
|
|
begin
|
|
if FVertScrollWnd.Visible and FVertScrollWnd.Enabled then
|
|
begin
|
|
if VertUpState = tsArrowBtnUpPressed then
|
|
begin
|
|
VertUpState := tsArrowBtnUpNormal;
|
|
PaintScroll;
|
|
end;
|
|
|
|
if VertDownState = tsArrowBtnDownPressed then
|
|
begin
|
|
VertDownState := tsArrowBtnDownNormal;
|
|
PaintScroll;
|
|
end;
|
|
end;
|
|
|
|
if FHorzScrollWnd.Visible and FHorzScrollWnd.Enabled then
|
|
begin
|
|
if HorzUpState = tsArrowBtnLeftPressed then
|
|
begin
|
|
HorzUpState := tsArrowBtnLeftNormal;
|
|
PaintScroll;
|
|
end;
|
|
|
|
if HorzDownState = tsArrowBtnRightPressed then
|
|
begin
|
|
HorzDownState := tsArrowBtnRightNormal;
|
|
PaintScroll;
|
|
end;
|
|
end;
|
|
|
|
CallDefaultProc(TMessage(Msg));
|
|
Handled := True;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.WMEraseBkgnd(var Msg: TWMEraseBkgnd);
|
|
begin
|
|
Handled := True;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.WMHScroll(var Msg: TWMHScroll);
|
|
begin
|
|
CallDefaultProc(TMessage(Msg));
|
|
if not (Msg.ScrollCode in [SB_THUMBTRACK, SB_THUMBPOSITION]) then
|
|
UpdateScroll
|
|
else
|
|
PaintScroll;
|
|
Handled := True;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.CMUpdateVclStyleScrollbars(var Msg: TMessage);
|
|
begin
|
|
CalcScrollBarsRect;
|
|
PaintScroll;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.WMKeyDown(var Msg: TMessage);
|
|
begin
|
|
CallDefaultProc(TMessage(Msg));
|
|
UpdateScroll;
|
|
Handled := True;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.WMKeyUp(var Msg: TMessage);
|
|
begin
|
|
CallDefaultProc(TMessage(Msg));
|
|
PaintScroll;
|
|
Handled := True;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.WMLButtonDown(var Msg: TWMMouse);
|
|
begin
|
|
CallDefaultProc(TMessage(Msg));
|
|
UpdateScroll;
|
|
Handled := True;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.WMLButtonUp(var Msg: TWMMouse);
|
|
var
|
|
P: TPoint;
|
|
begin
|
|
P := Point(Msg.XPos, Msg.YPos);
|
|
ScreenToClient(Handle, P);
|
|
if not PointInTreeHeader(P) then
|
|
begin
|
|
if FVertScrollWnd.Visible then
|
|
begin
|
|
if VertSliderState = tsThumbBtnVertPressed then
|
|
begin
|
|
PostMessage(Handle, WM_VSCROLL, Integer(SmallPoint(SB_ENDSCROLL, 0)), 0);
|
|
FLeftMouseButtonDown := False;
|
|
VertSliderState := tsThumbBtnVertNormal;
|
|
PaintScroll;
|
|
Handled := True;
|
|
Mouse.Capture := 0;
|
|
Exit;
|
|
end else
|
|
if VertUpState = tsArrowBtnUpPressed then
|
|
VertUpState := tsArrowBtnUpNormal
|
|
else if VertDownState = tsArrowBtnDownPressed then
|
|
VertDownState := tsArrowBtnDownNormal;
|
|
end;
|
|
|
|
if FHorzScrollWnd.Visible then
|
|
begin
|
|
if HorzSliderState = tsThumbBtnHorzPressed then
|
|
begin
|
|
PostMessage(Handle, WM_HSCROLL, Integer(SmallPoint(SB_ENDSCROLL, 0)), 0);
|
|
FLeftMouseButtonDown := False;
|
|
HorzSliderState := tsThumbBtnHorzNormal;
|
|
PaintScroll;
|
|
Handled := True;
|
|
Mouse.Capture := 0;
|
|
Exit;
|
|
end else
|
|
if HorzUpState = tsArrowBtnLeftPressed then
|
|
HorzUpState := tsArrowBtnLeftNormal
|
|
else if HorzDownState = tsArrowBtnRightPressed then
|
|
HorzDownState := tsArrowBtnRightNormal;
|
|
end;
|
|
PaintScroll;
|
|
end;
|
|
FLeftMouseButtonDown := False;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.WMMouseMove(var Msg: TWMMouse);
|
|
var
|
|
SF: TScrollInfo;
|
|
OverrideMax: Integer;
|
|
begin
|
|
if VertSliderState = tsThumbBtnVertPressed then
|
|
begin
|
|
SF.fMask := SIF_ALL;
|
|
SF.cbSize := SizeOf(SF);
|
|
GetScrollInfo(Handle, SB_VERT, SF);
|
|
|
|
OverrideMax := SF.nMax;
|
|
if 0 < SF.nPage then
|
|
OverrideMax := SF.nMax - Integer(SF.nPage) + 1;
|
|
ScrollPos := System.Math.EnsureRange(ListPos + (OverrideMax - SF.nMin) * ((Mouse.CursorPos.Y - PrevScrollPos) / (VertTrackRect.Height - VertSliderRect.Height)),
|
|
SF.nMin, OverrideMax);
|
|
SF.fMask := SIF_POS;
|
|
SF.nPos := Round(ScrollPos);
|
|
SetScrollInfo(Handle, SB_VERT, SF, False);
|
|
PostMessage(Handle, WM_VSCROLL, Integer(SmallPoint(SB_THUMBPOSITION, Min(SF.nPos, High(SmallInt)))), 0);
|
|
|
|
PaintScroll;
|
|
Handled := True;
|
|
Exit;
|
|
end else
|
|
if VertSliderState = tsThumbBtnVertHot then
|
|
begin
|
|
VertSliderState := tsThumbBtnVertNormal;
|
|
PaintScroll;
|
|
end;
|
|
|
|
if HorzSliderState = tsThumbBtnHorzPressed then
|
|
begin
|
|
SF.fMask := SIF_ALL;
|
|
SF.cbSize := SizeOf(SF);
|
|
GetScrollInfo(Handle, SB_HORZ, SF);
|
|
|
|
OverrideMax := SF.nMax;
|
|
if 0 < SF.nPage then
|
|
OverrideMax := SF.nMax - Integer(SF.nPage) + 1;
|
|
ScrollPos := System.Math.EnsureRange(ListPos + (OverrideMax - SF.nMin) * ((Mouse.CursorPos.X - PrevScrollPos) / (HorzTrackRect.Width - HorzSliderRect.Width)),
|
|
SF.nMin, OverrideMax);
|
|
SF.fMask := SIF_POS;
|
|
SF.nPos := Round(ScrollPos);
|
|
SetScrollInfo(Handle, SB_HORZ, SF, False);
|
|
PostMessage(Handle, WM_HSCROLL, Integer(SmallPoint(SB_THUMBPOSITION, Min(SF.nPos, High(SmallInt)))), 0);
|
|
|
|
PaintScroll;
|
|
Handled := True;
|
|
Exit;
|
|
end else
|
|
if HorzSliderState = tsThumbBtnHorzHot then
|
|
begin
|
|
HorzSliderState := tsThumbBtnHorzNormal;
|
|
PaintScroll;
|
|
end;
|
|
|
|
if (HorzUpState <> tsArrowBtnLeftPressed) and (HorzUpState = tsArrowBtnLeftHot) then
|
|
begin
|
|
HorzUpState := tsArrowBtnLeftNormal;
|
|
PaintScroll;
|
|
end;
|
|
|
|
if (HorzDownState <> tsArrowBtnRightPressed) and (HorzDownState = tsArrowBtnRightHot) then
|
|
begin
|
|
HorzDownState := tsArrowBtnRightNormal;
|
|
PaintScroll;
|
|
end;
|
|
|
|
if (VertUpState <> tsArrowBtnUpPressed) and (VertUpState = tsArrowBtnUpHot) then
|
|
begin
|
|
VertUpState := tsArrowBtnUpNormal;
|
|
PaintScroll;
|
|
end;
|
|
|
|
if (VertDownState <> tsArrowBtnDownPressed) and (VertDownState = tsArrowBtnDownHot) then
|
|
begin
|
|
VertDownState := tsArrowBtnDownNormal;
|
|
PaintScroll;
|
|
end;
|
|
|
|
CallDefaultProc(TMessage(Msg));
|
|
if FLeftMouseButtonDown then
|
|
PaintScroll;
|
|
Handled := True;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.WMMouseWheel(var Msg: TMessage);
|
|
begin
|
|
CallDefaultProc(TMessage(Msg));
|
|
CalcScrollBarsRect;
|
|
PaintScroll;
|
|
Handled := True;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.WMNCLButtonDblClk(var Msg: TWMMouse);
|
|
begin
|
|
WMNCLButtonDown(Msg);
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.WMNCLButtonDown(var Msg: TWMMouse);
|
|
var
|
|
P: TPoint;
|
|
SF: TScrollInfo;
|
|
begin
|
|
P := NCMousePosToClient(Point(Msg.XPos, Msg.YPos));
|
|
if not PointInTreeHeader(P) then
|
|
begin
|
|
if FVertScrollWnd.Visible and FVertScrollWnd.Enabled then
|
|
begin
|
|
if PtInRect(VertSliderRect, P) then
|
|
begin
|
|
FLeftMouseButtonDown := True;
|
|
SF.fMask := SIF_ALL;
|
|
SF.cbSize := SizeOf(SF);
|
|
GetScrollInfo(Handle, SB_VERT, SF);
|
|
ListPos := SF.nPos;
|
|
ScrollPos := SF.nPos;
|
|
PrevScrollPos := Mouse.CursorPos.Y;
|
|
VertSliderState := tsThumbBtnVertPressed;
|
|
PaintScroll;
|
|
Mouse.Capture := Handle;
|
|
Handled := True;
|
|
Exit;
|
|
end else
|
|
if PtInRect(VertDownButtonRect, P) then
|
|
VertDownState := tsArrowBtnDownPressed
|
|
else if PtInRect(VertUpButtonRect, P) then
|
|
VertUpState := tsArrowBtnUpPressed;
|
|
end;
|
|
|
|
if FHorzScrollWnd.Visible and FHorzScrollWnd.Enabled then
|
|
begin
|
|
if PtInRect(HorzSliderRect, P) then
|
|
begin
|
|
FLeftMouseButtonDown := True;
|
|
SF.fMask := SIF_ALL;
|
|
SF.cbSize := SizeOf(SF);
|
|
GetScrollInfo(Handle, SB_HORZ, SF);
|
|
ListPos := SF.nPos;
|
|
ScrollPos := SF.nPos;
|
|
PrevScrollPos := Mouse.CursorPos.X;
|
|
HorzSliderState := tsThumbBtnHorzPressed;
|
|
PaintScroll;
|
|
Mouse.Capture := Handle;
|
|
Handled := True;
|
|
Exit;
|
|
end else
|
|
if PtInRect(HorzDownButtonRect, P) then
|
|
HorzDownState := tsArrowBtnRightPressed
|
|
else if PtInRect(HorzUpButtonRect, P) then
|
|
HorzUpState := tsArrowBtnLeftPressed;
|
|
end;
|
|
FLeftMouseButtonDown := True;
|
|
PaintScroll;
|
|
end;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.WMNCLButtonUp(var Msg: TWMMouse);
|
|
var
|
|
P: TPoint;
|
|
begin
|
|
P := NCMousePosToClient(Point(Msg.XPos, Msg.YPos));
|
|
if not PointInTreeHeader(P) then
|
|
begin
|
|
if FVertScrollWnd.Visible and FVertScrollWnd.Enabled then
|
|
begin
|
|
if VertSliderState = tsThumbBtnVertPressed then
|
|
begin
|
|
FLeftMouseButtonDown := False;
|
|
VertSliderState := tsThumbBtnVertNormal;
|
|
PaintScroll;
|
|
Handled := True;
|
|
Exit;
|
|
end;
|
|
|
|
if PtInRect(VertDownButtonRect, P) then
|
|
VertDownState := tsArrowBtnDownHot
|
|
else
|
|
VertDownState := tsArrowBtnDownNormal;
|
|
|
|
if PtInRect(VertUpButtonRect, P) then
|
|
VertUpState := tsArrowBtnUpHot
|
|
else
|
|
VertUpState := tsArrowBtnUpNormal;
|
|
end;
|
|
|
|
if FHorzScrollWnd.Visible and FHorzScrollWnd.Enabled then
|
|
begin
|
|
if HorzSliderState = tsThumbBtnHorzPressed then
|
|
begin
|
|
FLeftMouseButtonDown := False;
|
|
HorzSliderState := tsThumbBtnHorzNormal;
|
|
PaintScroll;
|
|
Handled := True;
|
|
Exit;
|
|
end;
|
|
|
|
if PtInRect(HorzDownButtonRect, P) then
|
|
HorzDownState := tsArrowBtnRightHot
|
|
else
|
|
HorzDownState := tsArrowBtnRightNormal;
|
|
|
|
if PtInRect(HorzUpButtonRect, P) then
|
|
HorzUpState := tsArrowBtnLeftHot
|
|
else
|
|
HorzUpState := tsArrowBtnLeftNormal;
|
|
end;
|
|
|
|
CallDefaultProc(TMessage(Msg));
|
|
if (FHorzScrollWnd.Visible) or (FVertScrollWnd.Visible) then
|
|
PaintScroll;
|
|
end;
|
|
|
|
Handled := True;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.WMNCMouseMove(var Msg: TWMMouse);
|
|
var
|
|
P: TPoint;
|
|
MustUpdateScroll: Boolean;
|
|
B: Boolean;
|
|
begin
|
|
inherited;
|
|
P := NCMousePosToClient(Point(Msg.XPos, Msg.YPos));
|
|
if PointInTreeHeader(P) then
|
|
begin
|
|
CallDefaultProc(TMessage(Msg));
|
|
PaintScroll;
|
|
Handled := True;
|
|
Exit;
|
|
end;
|
|
|
|
MustUpdateScroll := False;
|
|
if FVertScrollWnd.Visible and FVertScrollWnd.Enabled then
|
|
begin
|
|
B := PtInRect(VertSliderRect, P);
|
|
if B and (VertSliderState = tsThumbBtnVertNormal) then
|
|
begin
|
|
VertSliderState := tsThumbBtnVertHot;
|
|
MustUpdateScroll := True;
|
|
end else
|
|
if not B and (VertSliderState = tsThumbBtnVertHot) then
|
|
begin
|
|
VertSliderState := tsThumbBtnVertNormal;
|
|
MustUpdateScroll := True;
|
|
end;
|
|
|
|
B := PtInRect(VertDownButtonRect, P);
|
|
if B and (VertDownState = tsArrowBtnDownNormal) then
|
|
begin
|
|
VertDownState := tsArrowBtnDownHot;
|
|
MustUpdateScroll := True;
|
|
end else
|
|
if not B and (VertDownState = tsArrowBtnDownHot) then
|
|
begin
|
|
VertDownState := tsArrowBtnDownNormal;
|
|
MustUpdateScroll := True;
|
|
end;
|
|
|
|
B := PtInRect(VertUpButtonRect, P);
|
|
if B and (VertUpState = tsArrowBtnUpNormal) then
|
|
begin
|
|
VertUpState := tsArrowBtnUpHot;
|
|
MustUpdateScroll := True;
|
|
end else
|
|
if not B and (VertUpState = tsArrowBtnUpHot) then
|
|
begin
|
|
VertUpState := tsArrowBtnUpNormal;
|
|
MustUpdateScroll := True;
|
|
end;
|
|
end;
|
|
|
|
if FHorzScrollWnd.Visible and FHorzScrollWnd.Enabled then
|
|
begin
|
|
B := PtInRect(HorzSliderRect, P);
|
|
if B and (HorzSliderState = tsThumbBtnHorzNormal) then
|
|
begin
|
|
HorzSliderState := tsThumbBtnHorzHot;
|
|
MustUpdateScroll := True;
|
|
end else
|
|
if not B and (HorzSliderState = tsThumbBtnHorzHot) then
|
|
begin
|
|
HorzSliderState := tsThumbBtnHorzNormal;
|
|
MustUpdateScroll := True;
|
|
end;
|
|
|
|
B := PtInRect(HorzDownButtonRect, P);
|
|
if B and (HorzDownState = tsArrowBtnRightNormal) then
|
|
begin
|
|
HorzDownState := tsArrowBtnRightHot;
|
|
MustUpdateScroll := True;
|
|
end else
|
|
if not B and (HorzDownState = tsArrowBtnRightHot) then
|
|
begin
|
|
HorzDownState := tsArrowBtnRightNormal;
|
|
MustUpdateScroll := True;
|
|
end;
|
|
|
|
B := PtInRect(HorzUpButtonRect, P);
|
|
if B and (HorzUpState = tsArrowBtnLeftNormal) then
|
|
begin
|
|
HorzUpState := tsArrowBtnLeftHot;
|
|
MustUpdateScroll := True;
|
|
end else
|
|
if not B and (HorzUpState = tsArrowBtnLeftHot) then
|
|
begin
|
|
HorzUpState := tsArrowBtnLeftNormal;
|
|
MustUpdateScroll := True;
|
|
end;
|
|
end;
|
|
|
|
if MustUpdateScroll then
|
|
PaintScroll;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.WMNCPaint(var Msg: TMessage);
|
|
begin
|
|
//if (tsWindowCreating in TBaseVirtualTree(Control).TreeStates) then
|
|
// UpdateScrollBarWindow;
|
|
//inherited;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.WMSize(var Msg: TMessage);
|
|
begin
|
|
CallDefaultProc(TMessage(Msg));
|
|
UpdateScroll;
|
|
PaintScroll;
|
|
Handled := True;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.WMMove(var Msg: TMessage);
|
|
begin
|
|
CallDefaultProc(TMessage(Msg));
|
|
if not(tsWindowCreating in TBaseVirtualTree(Control).TreeStates) then
|
|
begin
|
|
UpdateScroll;
|
|
PaintScroll;
|
|
end;
|
|
Handled := True;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.WMPosChanged(var Msg: TMessage);
|
|
begin
|
|
WMMove(Msg);
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.WMVScroll(var Msg: TWMVScroll);
|
|
begin
|
|
CallDefaultProc(TMessage(Msg));
|
|
if not (Msg.ScrollCode in [SB_THUMBTRACK, SB_THUMBPOSITION]) then
|
|
UpdateScroll
|
|
else
|
|
PaintScroll;
|
|
Handled := True;
|
|
end;
|
|
|
|
{ TVclStyleScrollBarsHook.TVclStyleScrollBarWindow }
|
|
|
|
constructor TVclStyleScrollBarsHook.TScrollWindow.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
ControlStyle := ControlStyle + [csOverrideStylePaint];
|
|
FStyleHook := nil;
|
|
FVertical := False;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.TScrollWindow.WMEraseBkgnd(var Msg: TMessage);
|
|
begin
|
|
Msg.Result := 1;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.TScrollWindow.WMNCHitTest(var Msg: TWMNCHitTest);
|
|
begin
|
|
Msg.Result := HTTRANSPARENT;
|
|
end;
|
|
|
|
procedure TVclStyleScrollBarsHook.TScrollWindow.WMPaint(var Msg: TWMPaint);
|
|
var
|
|
PS: TPaintStruct;
|
|
DC: HDC;
|
|
R: TRect;
|
|
begin
|
|
BeginPaint(Handle, PS);
|
|
try
|
|
if FStyleHook <> nil then
|
|
begin
|
|
DC := GetWindowDC(Handle);
|
|
try
|
|
if FVertical then
|
|
begin
|
|
R := FStyleHook.VertScrollRect;
|
|
MoveWindowOrg(DC, -R.Left, -R.Top);
|
|
FStyleHook.DrawVertScrollBar(DC);
|
|
end else
|
|
begin
|
|
R := FStyleHook.HorzScrollRect;
|
|
MoveWindowOrg(DC, -R.Left, -R.Top);
|
|
FStyleHook.DrawHorzScrollBar(DC);
|
|
end;
|
|
finally
|
|
ReleaseDC(Handle, DC);
|
|
end;
|
|
end;
|
|
finally
|
|
EndPaint(Handle, PS);
|
|
end;
|
|
end;
|
|
|
|
initialization
|
|
TCustomStyleEngine.RegisterStyleHook(TVirtualStringTree, TVclStyleScrollBarsHook);
|
|
TCustomStyleEngine.RegisterStyleHook(TVirtualDrawTree, TVclStyleScrollBarsHook);
|
|
|
|
finalization
|
|
TCustomStyleEngine.UnRegisterStyleHook(TVirtualStringTree, TVclStyleScrollBarsHook);
|
|
TCustomStyleEngine.UnRegisterStyleHook(TVirtualDrawTree, TVclStyleScrollBarsHook);
|
|
|
|
end.
|
|
|