paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-12-06 13:47:41 +01:00
Code Issues Packages Projects Releases Wiki Activity

VirtualTreeView: Scaled reference point image for wheel panning

Browse Source 
git-svn-id: trunk@59413 -
This commit is contained in:
wp 2018-10-31 21:02:51 +00:00
parent 0efd89986e
commit 14fef5b267
3 changed files with 22 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
components/virtualtreeview/VirtualTrees.pas
View File

@ -25109,6 +25109,8 @@ end;
//---------------------------------------------------------------------------------------------------------------------- //----------------------------------------------------------------------------------------------------------------------
procedure TBaseVirtualTree.StartWheelPanning(const Position: TPoint); procedure TBaseVirtualTree.StartWheelPanning(const Position: TPoint);
const
TRANSPARENT_COLOR = $FFFFFE;
// Called when wheel panning should start. A little helper window is created to indicate the reference position, // Called when wheel panning should start. A little helper window is created to indicate the reference position,
// which determines in which direction and how far wheel panning/scrolling will happen. // which determines in which direction and how far wheel panning/scrolling will happen.
@ -25139,10 +25141,10 @@ procedure TBaseVirtualTree.StartWheelPanning(const Position: TPoint);
for X := 0 to ImageWidth - 1 do for X := 0 to ImageWidth - 1 do
begin begin
// Start a new span if we found a non-transparent pixel and no span is currently started. // Start a new span if we found a non-transparent pixel and no span is currently started.
if (Start = -1) and (Pixels[X, Y] <> clFuchsia) then if (Start = -1) and (Pixels[X, Y] <> TRANSPARENT_COLOR) then
Start := X Start := X
else else
if (Start > -1) and (Pixels[X, Y] = clFuchsia) then if (Start > -1) and (Pixels[X, Y] = TRANSPARENT_COLOR) then
begin begin
// A non-transparent span is finished. Add it to the result region. // A non-transparent span is finished. Add it to the result region.
Temp := CreateRectRgn(Start, Y, X, Y + 1); Temp := CreateRectRgn(Start, Y, X, Y + 1);
@ -25168,6 +25170,7 @@ procedure TBaseVirtualTree.StartWheelPanning(const Position: TPoint);
var var
ImageName: string; ImageName: string;
bm: TCustomBitmap;
begin begin
// Set both panning and scrolling flag. One will be removed shortly depending on whether the middle mouse button is // Set both panning and scrolling flag. One will be removed shortly depending on whether the middle mouse button is
@ -25194,7 +25197,16 @@ begin
else else
ImageName := 'VT_MOVENS_BMP'; ImageName := 'VT_MOVENS_BMP';
FPanningWindow.Image.LoadFromResourceName(0, ImageName); bm := CreateBitmapFromResourceName(0, BuildResourceName(ImageName)); // is png!
try
FPanningWindow.Image.SetSize(bm.Width, bm.Height);
FPanningWindow.Image.Canvas.Brush.Color := TRANSPARENT_COLOR;
FPanningWindow.Image.Canvas.FillRect(0, 0, bm.Width, bm.Height);
FPanningWindow.Image.Transparent := true;
FPanningWindow.Image.Canvas.Draw(0, 0, bm);
finally
bm.Free;
end;
FPanningWindow.Show(CreateClipRegion); FPanningWindow.Show(CreateClipRegion);

BIN
components/virtualtreeview/VirtualTrees.res
View File

Binary file not shown.

8
components/virtualtreeview/units/win32/virtualpanningwindow.pas
View File

@ -75,6 +75,7 @@ end;
procedure TVirtualPanningWindow.Start(OwnerHandle: THandle; const Position: TPoint); procedure TVirtualPanningWindow.Start(OwnerHandle: THandle; const Position: TPoint);
var var
TempClass: TWndClass; TempClass: TWndClass;
lSize: TSize;
begin begin
// Register the helper window class. // Register the helper window class.
if not GetClassInfo(HInstance, PanningWindowClass.lpszClassName, {%H-}TempClass) then if not GetClassInfo(HInstance, PanningWindowClass.lpszClassName, {%H-}TempClass) then
@ -84,9 +85,12 @@ begin
end; end;
// Create the helper window and show it at the given position without activating it. // Create the helper window and show it at the given position without activating it.
lSize.CX := MulDiv(32, ScreenInfo.PixelsPerInchX, 96);
lSize.CY := MulDiv(32, ScreenInfo.PixelsPerInchY, 96);
with Position do with Position do
FHandle := CreateWindowEx(WS_EX_TOOLWINDOW, PanningWindowClass.lpszClassName, nil, WS_POPUP, X - 16, Y - 16, FHandle := CreateWindowEx(WS_EX_TOOLWINDOW, PanningWindowClass.lpszClassName,
32, 32, OwnerHandle, 0, HInstance, nil); nil, WS_POPUP, X - lSize.CX div 2, Y - lSize.CY div 2, lSize.CX, lSize.CY,
OwnerHandle, 0, HInstance, nil);
//todo use SetWindowLongPtr later //todo use SetWindowLongPtr later
SetWindowLong(FHandle,GWL_USERDATA,PtrInt(Self)); SetWindowLong(FHandle,GWL_USERDATA,PtrInt(Self));