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
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
|
unit virtualpanningwindow;
{Adapted from VirtualTrees by Luiz Amrico to work in LCL/Lazarus}
{$mode objfpc}{$H+}
interface
uses
Windows, Graphics, Classes, SysUtils;
type
{ TVirtualPanningWindow }
TVirtualPanningWindow = class
private
FHandle: THandle;
FImage: TBitmap;
procedure HandlePaintMessage;
public
procedure Start(OwnerHandle: THandle; const Position: TPoint);
procedure Stop;
procedure Show(ClipRegion: HRGN);
property Image: TBitmap read FImage;
property Handle: THandle read FHandle;
end;
implementation
{$ifdef DEBUG_VTV}
uses
vtlogger;
{$endif}
function {%H-}PanningWindowProc(Window: HWnd; Msg: UInt;WPara: WParam; LPara: LParam): LResult; stdcall;
var
PanningObject: TVirtualPanningWindow;
begin
if Msg = WM_PAINT then
begin
PanningObject:=TVirtualPanningWindow(GetWindowLongPtrW(Window,GWL_USERDATA));
if Assigned(PanningObject) then
PanningObject.HandlePaintMessage;
end
else
DefWindowProc(Window,Msg,WPara,LPara);
end;
var
PanningWindowClass: TWndClass = (
style: 0;
lpfnWndProc: @PanningWindowProc;
cbClsExtra: 0;
cbWndExtra: 0;
hInstance: 0;
hIcon: 0;
hCursor: 0;
hbrBackground: 0;
lpszMenuName: nil;
lpszClassName: 'VTPanningWindow'
);
{ TVirtualPanningWindow }
procedure TVirtualPanningWindow.HandlePaintMessage;
var
PS: PaintStruct;
begin
BeginPaint(FHandle, {%H-}PS);
BitBlt(PS.hdc,0,0,FImage.Width,FImage.Height,FImage.Canvas.Handle,0,0,SRCCOPY);
EndPaint(FHandle, PS);
end;
procedure TVirtualPanningWindow.Start(OwnerHandle: THandle; const Position: TPoint);
var
TempClass: TWndClass;
begin
// Register the helper window class.
if not GetClassInfo(HInstance, PanningWindowClass.lpszClassName, {%H-}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,
32, 32, OwnerHandle, 0, HInstance, nil);
//todo use SetWindowLongPtr later
SetWindowLong(FHandle,GWL_USERDATA,PtrInt(Self));
FImage := TBitmap.Create;
end;
procedure TVirtualPanningWindow.Stop;
begin
// Destroy the helper window.
DestroyWindow(FHandle);
FImage.Free;
FImage := nil;
end;
procedure TVirtualPanningWindow.Show(ClipRegion: HRGN);
begin
{$ifdef DEBUG_VTV}Logger.SendBitmap([lcPanning],'Panning Image',FImage);{$endif}
//todo: move SetWindowRgn to DelphiCompat
SetWindowRgn(FHandle, ClipRegion, False);
ShowWindow(FHandle, SW_SHOWNOACTIVATE);
end;
end.
|
