1 { $Id: pairsplitter.pas 61929 2019-09-26 17:25:46Z martin $ }
2 {
3 /***************************************************************************
4 pairsplitter.pas
5 ----------------
6 Component Library Controls
7
8
9 ***************************************************************************/
10
11 *****************************************************************************
12 This file is part of the Lazarus Component Library (LCL)
13
14 See the file COPYING.modifiedLGPL.txt, included in this distribution,
15 for details about the license.
16 *****************************************************************************
17
18 Author: Mattias Gaertner
19
20 Abstract:
21 TPairSplitter component. A component with two TPairSplitterSide children.
22 Both child components can contain other components and the children are
23 divided by a splitter which can be dragged by the user.
24 }
25 unit PairSplitter;
26
27 {$mode objfpc}{$H+}
28
29 interface
30
31 uses
32 Types, Classes, SysUtils,
33 // LazUtils
34 LazTracer,
35 // LCL
36 LCLType, LCLIntf, LMessages, Graphics, Controls, ExtCtrls;
37
38 type
39 TCustomPairSplitter = class;
40
41 { TPairSplitterSide }
42
43 TPairSplitterSide = class(TWinControl)
44 private
45 fCreatedBySplitter: boolean;
GetSplitternull46 function GetSplitter: TCustomPairSplitter;
47 protected
48 class procedure WSRegisterClass; override;
49 procedure SetParent(AParent: TWinControl); override;
50 procedure WMPaint(var PaintMessage: TLMPaint); message LM_PAINT;
51 procedure Paint; virtual;
52 property Align;
53 property Anchors;
54 public
55 constructor Create(TheOwner: TComponent); override;
56 destructor Destroy; override;
57 public
58 property Splitter: TCustomPairSplitter read GetSplitter;
59 property Visible;
60 property Left;
61 property Top;
62 property Width;
63 property Height;
64 published
65 property ChildSizing;
66 property ClientWidth;
67 property ClientHeight;
68 property Constraints;
69 property Cursor;
70 property Enabled;
71 property OnMouseDown;
72 property OnMouseEnter;
73 property OnMouseLeave;
74 property OnMouseMove;
75 property OnMouseUp;
76 property OnMouseWheel;
77 property OnMouseWheelDown;
78 property OnMouseWheelUp;
79 property OnResize;
80 property ShowHint;
81 property ParentShowHint;
82 property PopupMenu;
83 end;
84
85 { TCustomPairSplitter }
86
87 TPairSplitterType = (
88 pstHorizontal,
89 pstVertical
90 );
91
92 TCustomPairSplitter = class(TWinControl)
93 private
94 FPosition: integer;
95 FSides: array[0..1] of TPairSplitterSide;
96 FSplitterType: TPairSplitterType;
97 FDoNotCreateSides: boolean;
98 FLoadCursor: TCursor;
GetPositionnull99 function GetPosition: integer;
GetSidesnull100 function GetSides(Index: integer): TPairSplitterSide;
101 procedure SetPosition(const AValue: integer);
102 procedure SetSplitterType(const AValue: TPairSplitterType);
103 procedure AddSide(ASide: TPairSplitterSide);
104 procedure RemoveSide(ASide: TPairSplitterSide);
105 protected
106 class procedure WSRegisterClass; override;
GetCursornull107 function GetCursor: TCursor; override;
108 procedure SetCursor(Value: TCursor); override;
GetControlClassDefaultSizenull109 class function GetControlClassDefaultSize: TSize; override;
110 public
111 constructor Create(TheOwner: TComponent); override;
112 destructor Destroy; override;
113 procedure CreateWnd; override;
114 procedure UpdatePosition;
115 procedure CreateSides;
116 procedure Loaded; override;
ChildClassAllowednull117 function ChildClassAllowed(ChildClass: TClass): boolean; override;
118 public
119 property Cursor default crHSplit;
120 property Sides[Index: integer]: TPairSplitterSide read GetSides;
121 property SplitterType: TPairSplitterType read FSplitterType
122 write SetSplitterType default pstHorizontal;
123 property Position: integer read GetPosition write SetPosition;
124 end;
125
126
127 { TPairSplitter }
128
129 TPairSplitter = class(TCustomPairSplitter)
130 published
131 property Align;
132 property Anchors;
133 property BorderSpacing;
134 property Constraints;
135 property Color;
136 property Cursor;
137 property Enabled;
138 property OnMouseDown;
139 property OnMouseEnter;
140 property OnMouseLeave;
141 property OnMouseMove;
142 property OnMouseUp;
143 property OnMouseWheel;
144 property OnMouseWheelDown;
145 property OnMouseWheelUp;
146 property OnResize;
147 property OnChangeBounds;
148 property ParentShowHint;
149 property PopupMenu;
150 property Position;
151 property ShowHint;
152 property SplitterType;
153 property Visible;
154 end;
155
156 procedure Register;
157
158 implementation
159
160 uses
161 WSPairSplitter;
162
163 procedure Register;
164 begin
165 RegisterComponents('Additional',[TPairSplitter]);
166 RegisterNoIcon([TPairSplitterSide]);
167 end;
168
169 { TPairSplitterSide }
170
GetSplitternull171 function TPairSplitterSide.GetSplitter: TCustomPairSplitter;
172 begin
173 if (Parent<>nil) and (Parent is TCustomPairSplitter) then
174 Result:=TCustomPairSplitter(Parent)
175 else
176 Result:=nil;
177 end;
178
179 class procedure TPairSplitterSide.WSRegisterClass;
180 begin
181 inherited WSRegisterClass;
182 RegisterPairSplitterSide;
183 end;
184
185 procedure TPairSplitterSide.SetParent(AParent: TWinControl);
186 var
187 ASplitter: TCustomPairSplitter;
188 DeletingSplitter: Boolean;
189 begin
190 CheckNewParent(AParent);
191 // remove from side list of old parent
192 ASplitter := Splitter;
193 if ASplitter <> nil then begin
194 ASplitter.RemoveSide(Self);
195 DeletingSplitter := (csDestroying in ASplitter.ComponentState) or DesignerDeleting;
196 end
197 else
198 DeletingSplitter := False;
199
200 inherited SetParent(AParent);
201
202 if not DeletingSplitter then begin
203 // add to side list of new parent
204 ASplitter:=Splitter;
205 if ASplitter <> nil then
206 ASplitter.AddSide(Self);
207 end;
208 end;
209
210 procedure TPairSplitterSide.WMPaint(var PaintMessage: TLMPaint);
211 begin
212 if (csDestroying in ComponentState) or (not HandleAllocated) then
213 Exit;
214 Include(FControlState, csCustomPaint);
215 inherited WMPaint(PaintMessage);
216 Paint;
217 Exclude(FControlState, csCustomPaint);
218 end;
219
220 procedure TPairSplitterSide.Paint;
221 var
222 ACanvas: TControlCanvas;
223 begin
224 if csDesigning in ComponentState then
225 begin
226 ACanvas := TControlCanvas.Create;
227 with ACanvas do
228 begin
229 Control := Self;
230 Pen.Style := psDash;
231 Frame(0,0,Width-1,Height-1);
232 Free;
233 end;
234 end;
235 end;
236
237 constructor TPairSplitterSide.Create(TheOwner: TComponent);
238 begin
239 inherited Create(TheOwner);
240 FCompStyle := csPairSplitterSide;
241 ControlStyle := ControlStyle + [csAcceptsControls];
242 end;
243
244 destructor TPairSplitterSide.Destroy;
245 begin
246 inherited Destroy;
247 end;
248
249 { TCustomPairSplitter }
250
TCustomPairSplitter.GetSidesnull251 function TCustomPairSplitter.GetSides(Index: integer): TPairSplitterSide;
252 begin
253 if (Index < 0) or (Index > 1) then
254 RaiseGDBException('TCustomPairSplitter.GetSides: Index out of bounds');
255 Result := FSides[Index];
256 end;
257
GetPositionnull258 function TCustomPairSplitter.GetPosition: integer;
259 begin
260 if HandleAllocated and (not (csLoading in ComponentState)) then
261 UpdatePosition;
262 Result := FPosition;
263 end;
264
265 procedure TCustomPairSplitter.SetPosition(const AValue: integer);
266 begin
267 if (FPosition = AValue) and
268 (TWSCustomPairSplitterClass(WidgetSetClass).GetPosition(Self) = FPosition)
269 then
270 Exit;
271
272 FPosition := AValue;
273 if FPosition < 0 then
274 FPosition := 0;
275 if HandleAllocated and (not (csLoading in ComponentState)) then
276 TWSCustomPairSplitterClass(WidgetSetClass).SetPosition(Self, FPosition);
277 end;
278
279 procedure TCustomPairSplitter.SetSplitterType(const AValue: TPairSplitterType);
280 const
281 DefaultCursors: array[TPairSplitterType] of TCursor =
282 (
283 { pstHorizontal } crHSplit,
284 { pstVertical } crVSplit
285 );
286 begin
287 if FSplitterType = AValue then
288 Exit;
289
290 if Cursor = DefaultCursors[FSplitterType] then
291 Cursor := DefaultCursors[AValue];
292
293 FSplitterType := AValue;
294
295 // TODO: Remove RecreateWnd
296 if HandleAllocated then
297 RecreateWnd(Self);
298 end;
299
300 procedure TCustomPairSplitter.AddSide(ASide: TPairSplitterSide);
301 var
302 i: Integer;
303 begin
304 if ASide = nil then
305 Exit;
306 i := Low(FSides);
307 repeat
308 if FSides[i] = ASide then
309 Exit;
310 if FSides[i] =nil then
311 begin
312 FSides[i] := ASide;
313 if HandleAllocated then
314 TWSCustomPairSplitterClass(WidgetSetClass).AddSide(Self, ASide, i);
315 break;
316 end;
317 inc(i);
318 if i > High(FSides) then
319 RaiseGDBException('TCustomPairSplitter.AddSide no free side left');
320 until False;
321 end;
322
323 procedure TCustomPairSplitter.RemoveSide(ASide: TPairSplitterSide);
324 var
325 i: Integer;
326 begin
327 if ASide = nil then
328 Exit;
329 for i := Low(FSides) to High(FSides) do
330 if FSides[i]=ASide then
331 begin
332 if HandleAllocated and ASide.HandleAllocated then
333 TWSCustomPairSplitterClass(WidgetSetClass).RemoveSide(Self, ASide, i);
334 FSides[i] := nil;
335 end;
336 // if the user deletes a side at designtime, autocreate a new one
337 if (ComponentState * [csDesigning,csDestroying] = [csDesigning])
338 and not DesignerDeleting then
339 CreateSides;
340 end;
341
342 class procedure TCustomPairSplitter.WSRegisterClass;
343 begin
344 inherited WSRegisterClass;
345 RegisterCustomPairSplitter;
346 end;
347
GetCursornull348 function TCustomPairSplitter.GetCursor: TCursor;
349 begin
350 // Paul Ishenin: I do not know another method to tell internal splitter about
351 // cursor changes
352
353 // if widgetset class do not want to get cursor (has no internal splitter) then
354 // use default lcl handler
355 if not TWSCustomPairSplitterClass(WidgetSetClass).GetSplitterCursor(Self, Result) then
356 Result := inherited GetCursor;
357 end;
358
359 procedure TCustomPairSplitter.SetCursor(Value: TCursor);
360 begin
361 FLoadCursor := Value;
362 if not HandleAllocated then
363 Exit;
364 // if widgetset class do not want to set cursor (has no internal splitter) then
365 // use default lcl handler
366 if not TWSCustomPairSplitterClass(WidgetSetClass).SetSplitterCursor(Self, Value) then
367 inherited SetCursor(Value);
368 end;
369
TCustomPairSplitter.GetControlClassDefaultSizenull370 class function TCustomPairSplitter.GetControlClassDefaultSize: TSize;
371 begin
372 Result.CX := 90;
373 Result.CY := 90;
374 end;
375
376 constructor TCustomPairSplitter.Create(TheOwner: TComponent);
377 begin
378 inherited Create(TheOwner);
379 FCompStyle := csPairSplitter;
380 ControlStyle := ControlStyle - [csAcceptsControls];
381 FSplitterType := pstHorizontal;
382 Cursor := crHSplit;
383 with GetControlClassDefaultSize do
384 SetInitialBounds(0, 0, CX, CY);
385 FPosition:=45;
386 if not (csDesigning in ComponentState) then
387 CreateSides;
388 end;
389
390 destructor TCustomPairSplitter.Destroy;
391 var
392 i: Integer;
393 begin
394 // destroy the sides
395 fDoNotCreateSides:=true;
396 for i:=Low(FSides) to High(FSides) do
397 if (FSides[i]<>nil) and (FSides[i].fCreatedBySplitter) then
398 FSides[i].Free;
399 inherited Destroy;
400 end;
401
402 procedure TCustomPairSplitter.CreateWnd;
403 var
404 i: Integer;
405 APosition: Integer;
406 begin
407 CreateSides;
408 inherited CreateWnd;
409 for i := Low(FSides) to High(FSides) do
410 if FSides[i] <> nil then
411 TWSCustomPairSplitterClass(WidgetSetClass).AddSide(Self, FSides[i], i);
412 APosition := FPosition;
413 TWSCustomPairSplitterClass(WidgetSetClass).SetPosition(Self, APosition);
414 SetCursor(FLoadCursor);
415 if not (csLoading in ComponentState) then
416 FPosition := APosition;
417 end;
418
419 procedure TCustomPairSplitter.UpdatePosition;
420 var
421 CurPosition: Integer;
422 begin
423 if HandleAllocated then
424 begin
425 CurPosition := -1;
426 TWSCustomPairSplitterClass(WidgetSetClass).SetPosition(Self, CurPosition);
427 FPosition := CurPosition;
428 end;
429 end;
430
431 procedure TCustomPairSplitter.CreateSides;
432 var
433 ASide: TPairSplitterSide;
434 i: Integer;
435 begin
436 if fDoNotCreateSides or (csDestroying in ComponentState)
437 or (csLoading in ComponentState)
438 or ((Owner<>nil) and (csLoading in Owner.ComponentState)) then exit;
439 // create the missing side controls
440 for i := Low(FSides) to High(FSides) do
441 if FSides[i]=nil then
442 begin
443 // For streaming it is important that the side controls are owned by
444 // the owner of the splitter
445 ASide:=TPairSplitterSide.Create(Owner);
446 ASide.fCreatedBySplitter:=true;
447 ASide.Parent:=Self;
448 end;
449 end;
450
451 procedure TCustomPairSplitter.Loaded;
452 begin
453 inherited Loaded;
454 CreateSides;
455 if HandleAllocated then
456 TWSCustomPairSplitterClass(WidgetSetClass).SetPosition(Self, FPosition);
457 end;
458
ChildClassAllowednull459 function TCustomPairSplitter.ChildClassAllowed(ChildClass: TClass): boolean;
460 begin
461 Result := ChildClass.InheritsFrom(TPairSplitterSide) or
462 ChildClass.InheritsFrom(TSplitter);
463 end;
464
465 end.
466