pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

Fixed Panning window draw

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@141 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
blikblum
2007-04-06 00:57:17 +00:00
parent 28313808a3
commit 213e0cc3b1
2 changed files with 16 additions and 20 deletions
Download Patch File Download Diff File Expand all files Collapse all files

13
components/virtualtreeview-unstable/VirtualTrees.pas
View File

@@ -23205,20 +23205,21 @@ procedure TBaseVirtualTree.StartWheelPanning(Position: TPoint);
// Since we only work on a very small image (32x32 pixels) this is acceptable.
var
Start, X, Y: Integer;
Start, X, Y, ImageHeight, ImageWidth: Integer;
Temp: HRGN;
begin
Assert(not FPanningWindow.Image.Empty, 'Invalid wheel panning image.');
ImageWidth:= FPanningWindow.Image.Width;
ImageHeight:= FPanningWindow.Image.Height;
// Create an initial region on which we operate.
Result := CreateRectRgn(0, 0, 0, 0);
with FPanningWindow.Image, Canvas do
with FPanningWindow.Image.Canvas do
begin
for Y := 0 to Height - 1 do
for Y := 0 to ImageHeight - 1 do
begin
Start := -1;
for X := 0 to Width - 1 do
for X := 0 to ImageWidth - 1 do
begin
// 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
@@ -23236,7 +23237,7 @@ procedure TBaseVirtualTree.StartWheelPanning(Position: TPoint);
// If there is an open span then add this also to the result region.
if Start > -1 then
begin
Temp := CreateRectRgn(Start, Y, Width, Y + 1);
Temp := CreateRectRgn(Start, Y, ImageWidth, Y + 1);
CombineRgn(Result, Result, Temp, RGN_OR);
DeleteObject(Temp);
end;

23
components/virtualtreeview-unstable/units/win32/virtualpanningwindow.pas
View File

@@ -1,5 +1,7 @@
unit virtualpanningwindow;
{Adapted from VirtualTrees by Luiz Am�rico to work in LCL/Lazarus}
{$mode objfpc}{$H+}
interface
@@ -8,7 +10,6 @@ uses
Windows, Graphics, Classes, SysUtils;
type
{ TVirtualPanningWindow }
TVirtualPanningWindow = class
@@ -63,18 +64,10 @@ var
procedure TVirtualPanningWindow.HandlePaintMessage;
var
PS: PaintStruct;
Canvas: TCanvas;
begin
BeginPaint(FHandle, PS);
Canvas := TCanvas.Create;
Canvas.Handle := PS.hdc;
try
Canvas.Draw(0, 0, FImage);
finally
Canvas.Handle := 0;
Canvas.Free;
EndPaint(FHandle, PS);
end;
BitBlt(PS.hdc,0,0,FImage.Width,FImage.Height,FImage.Canvas.Handle,0,0,SRCCOPY);
EndPaint(FHandle, PS);
end;
@@ -83,10 +76,12 @@ var
TempClass: TWndClass;
begin
// Register the helper window class.
PanningWindowClass.hInstance := HInstance;
if not GetClassInfo(HInstance, PanningWindowClass.lpszClassName, TempClass) then
begin
PanningWindowClass.hInstance := HInstance;
Windows.RegisterClass(PanningWindowClass);
end;
// Create the helper window and show it at the given position without activating it.
with Position do
FHandle := CreateWindowEx(WS_EX_TOOLWINDOW, PanningWindowClass.lpszClassName, nil, WS_POPUP, X - 16, Y - 16,
@@ -101,7 +96,6 @@ procedure TVirtualPanningWindow.Stop;
begin
// Destroy the helper window.
DestroyWindow(FHandle);
FHandle := 0;
FImage.Free;
FImage := nil;
end;
@@ -109,6 +103,7 @@ end;
procedure TVirtualPanningWindow.Show(ClipRegion: HRGN);
begin
Logger.SendBitmap([lcPanning],'Panning Image',FImage);
//todo: move SetWindowRgn to DelphiCompat
SetWindowRgn(FHandle, ClipRegion, False);
ShowWindow(FHandle, SW_SHOWNOACTIVATE);
end;