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
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
{%MainUnit ../controls.pp}
{******************************************************************************
TControlCanvas
******************************************************************************
*****************************************************************************
This file is part of the Lazarus Component Library (LCL)
See the file COPYING.modifiedLGPL.txt, included in this distribution,
for details about the license.
*****************************************************************************
}
{------------------------------------------------------------------------------
Method: TControlCanvas.SetControl
Params: AControl: The control this canvas belongs to
Returns: Nothing
Sets the owner of this canvas
------------------------------------------------------------------------------}
procedure TControlCanvas.SetControl(AControl: TControl);
begin
if FControl <> AControl then
begin
FreeHandle;
FControl := AControl;
end;
end;
function TControlCanvas.GetDefaultColor(const ADefaultColorType: TDefaultColorType): TColor;
begin
if Assigned(FControl) then
Result := FControl.GetDefaultColor(ADefaultColorType)
else
Result := inherited GetDefaultColor(ADefaultColorType);
end;
{------------------------------------------------------------------------------
Method: TControlCanvas.Create
Params: none
Returns: Nothing
Constructor for the class.
------------------------------------------------------------------------------}
constructor TControlCanvas.Create;
begin
inherited Create;
FDeviceContext := 0;
FControl := nil;
FWindowHandle := 0;
end;
{------------------------------------------------------------------------------
Method: TControlCanvas.Destroy
Params: None
Returns: Nothing
Destructor for the class.
------------------------------------------------------------------------------}
destructor TControlCanvas.Destroy;
begin
FreeHandle;
inherited Destroy;
end;
{------------------------------------------------------------------------------
Method: TControlCanvas.CreateHandle
Params: None
Returns: Nothing
Creates the handle ( = object).
------------------------------------------------------------------------------}
procedure TControlCanvas.CreateHandle;
var
WinControl: TWinControl;
begin
//DebugLn('[TControlCanvas.CreateHandle] ',FControl<>nil,' DC=',DbgS(FDeviceContext,8),' WinHandle=',DbgS(FWindowHandle,8));
if FControl = nil then
inherited CreateHandle
else
begin
{$IFDEF VerboseCanvas}
if not ControlIsPainting and
(WidgetSet.GetLCLCapability(lcCanDrawOutsideOnPaint) = LCL_CAPABILITY_NO) then
debugln(['TControlCanvas.CreateHandle WARNING: accessing the canvas of '+DbgSName(FControl)+' is not supported outside of paint message']);
{$ENDIF}
if (FDeviceContext = 0) then
begin
// access to window handle can cause another TControlCanvas.CreateHandle
// as result we get a resource leak. To prevent this require handle before
// accessing it
if FControl is TWinControl then
WinControl := TWinControl(FControl)
else
WinControl := FControl.Parent;
WinControl.HandleNeeded;
// important: keep the condition here again because
// CreateWnd (called via WinControl.HandleNeeded above) could execute
// this function again and thus allocate FDeviceContext twice
// resulting in a memory leak
if FDeviceContext = 0 then
begin
// store the handle locally since we need it to check (and do not
// want to fire creation events)
FDeviceContext := FControl.GetDeviceContext(FWindowHandle);
end;
end;
Handle := FDeviceContext;
end;
end;
{------------------------------------------------------------------------------
Method: TControlCanvas.FreeHandle
Params: None
Returns: Nothing
Frees the handle
------------------------------------------------------------------------------}
procedure TControlCanvas.FreeHandle;
begin
inherited;
if FDeviceContext <> 0 then
begin
ReleaseDC(FWindowHandle, FDeviceContext);
FDeviceContext := 0;
end;
end;
function TControlCanvas.ControlIsPainting: boolean;
begin
Result := Assigned(FControl) and FControl.IsProcessingPaintMsg;
end;
|
