1 { TDividerBevel
2
3 Copyright (C) 2010 Lazarus team
4
5 This library is free software; you can redistribute it and/or modify it
6 under the same terms as the Lazarus Component Library (LCL)
7
8 See the file COPYING.modifiedLGPL.txt, included in this distribution,
9 for details about the license.
10
11 }
12 unit DividerBevel;
13
14 {$mode objfpc}{$H+}
15
16 interface
17
18 uses
19 Classes, Types, Math,
20 // LCL
21 LCLType, LCLIntf, Controls, Graphics, ComCtrls, ExtCtrls, Themes,
22 // LazUtils
23 GraphType;
24
25 type
26 { TDividerBevel }
27
28 TDividerBevel = class(TGraphicControl)
29 private
30 FBevelStyle: TBevelStyle;
31 FBevelWidth: Integer;
32 FCaptionSpacing: Integer;
33 FLeftIndent: Integer;
34 FOrientation: TTrackBarOrientation;
35 FStyle: TGrabStyle;
36 FTransparent: Boolean;
37 procedure SetBevelStyle(AValue: TBevelStyle);
38 procedure SetBevelWidth(AValue: Integer);
39 procedure SetCaptionSpacing(const AValue: Integer);
40 procedure SetLeftIndent(const AValue: Integer);
41 procedure SetOrientation(AValue: TTrackBarOrientation);
42 procedure SetStyle(AValue: TGrabStyle);
43 procedure SetTransparent(AValue: Boolean);
44 protected
45 FBevelHeight: Integer;
46 FBevelTop: Integer;
47 FNeedCalcSize: Boolean;
48 FTextExtent: TSize;
GetControlClassDefaultSizenull49 class function GetControlClassDefaultSize: TSize; override;
50 procedure CalcSize;
51 procedure Paint; override;
52 procedure FontChanged(Sender: TObject); override;
53 procedure SetAutoSize(Value: Boolean); override;
54 procedure TextChanged; override;
55 procedure CalculatePreferredSize(
56 var PreferredWidth, PreferredHeight: Integer;
57 {%H-}WithThemeSpace: Boolean); override;
58 public
59 constructor Create(AOwner: TComponent); override;
60 procedure ShouldAutoAdjust(var AWidth, AHeight: Boolean); override;
61 published
62 property Caption;
63 property Align;
64 property AutoSize default True;
65 property Anchors;
66 property BevelStyle: TBevelStyle read FBevelStyle write SetBevelStyle default bsLowered;
67 property BevelWidth: Integer read FBevelWidth write SetBevelWidth default -1;
68 property BiDiMode;
69 property BorderSpacing;
70 property CaptionSpacing: Integer read FCaptionSpacing write SetCaptionSpacing
71 default 10;
72 property Color;
73 property Constraints;
74 property DragCursor;
75 property DragKind;
76 property DragMode;
77 property Font;
78 property Hint;
79 property LeftIndent: Integer read FLeftIndent write SetLeftIndent default 60;
80 property Orientation: TTrackBarOrientation read FOrientation write SetOrientation
81 default trHorizontal;
82 property ParentBiDiMode;
83 property ParentColor;
84 property ParentFont;
85 property ParentShowHint;
86 property PopupMenu;
87 property ShowHint;
88 property Style: TGrabStyle read FStyle write SetStyle default gsSimple;
89 property Transparent: Boolean read FTransparent write SetTransparent default True;
90 property Visible;
91 property OnChangeBounds;
92 property OnClick;
93 property OnContextPopup;
94 property OnDblClick;
95 property OnDragDrop;
96 property OnDragOver;
97 property OnEndDrag;
98 property OnMouseDown;
99 property OnMouseEnter;
100 property OnMouseLeave;
101 property OnMouseMove;
102 property OnMouseUp;
103 property OnResize;
104 property OnStartDrag;
105 end;
106
107 implementation
108
109 { TDividerBevel }
110
111 procedure TDividerBevel.SetBevelStyle(AValue: TBevelStyle);
112 begin
113 if FBevelStyle = AValue then Exit;
114 FBevelStyle := AValue;
115 Invalidate;
116 end;
117
118 procedure TDividerBevel.SetBevelWidth(AValue: Integer);
119 begin
120 if FBevelWidth = AValue then Exit;
121 FBevelWidth := AValue;
122 if AutoSize then begin
123 InvalidatePreferredSize;
124 AdjustSize;
125 end else
126 FNeedCalcSize := True;
127 Invalidate;
128 end;
129
130 procedure TDividerBevel.SetCaptionSpacing(const AValue: Integer);
131 begin
132 if FCaptionSpacing = AValue then Exit;
133 FCaptionSpacing := AValue;
134 Invalidate;
135 end;
136
137 procedure TDividerBevel.SetLeftIndent(const AValue: Integer);
138 begin
139 if FLeftIndent = AValue then Exit;
140 FLeftIndent := AValue;
141 Invalidate;
142 end;
143
144 procedure TDividerBevel.SetOrientation(AValue: TTrackBarOrientation);
145 begin
146 if FOrientation = AValue then Exit;
147 FOrientation := AValue;
148 if not (csLoading in ComponentState) then SetBounds(Left, Top, Height, Width);
149 if AutoSize then
150 begin
151 InvalidatePreferredSize;
152 AdjustSize;
153 end;
154 Invalidate;
155 end;
156
157 procedure TDividerBevel.SetStyle(AValue: TGrabStyle);
158 begin
159 if FStyle=AValue then Exit;
160 FStyle:=AValue;
161 Invalidate;
162 end;
163
164 procedure TDividerBevel.SetTransparent(AValue: Boolean);
165 begin
166 if FTransparent = AValue then Exit;
167 FTransparent := AValue;
168 Invalidate;
169 end;
170
TDividerBevel.GetControlClassDefaultSizenull171 class function TDividerBevel.GetControlClassDefaultSize: TSize;
172 begin
173 Result.CX := 240;
174 Result.CY := 17;
175 end;
176
177 procedure TDividerBevel.CalcSize;
178 begin
179 if not FNeedCalcSize then exit;
180 FNeedCalcSize := False;
181 if Caption = '' then
182 FTextExtent := Canvas.TextExtent(' ')
183 else
184 FTextExtent := Canvas.TextExtent(Caption);
185 if FBevelWidth < 0 then
186 FBevelHeight := Max(3, FTextExtent.cy div 5)
187 else
188 FBevelHeight := FBevelWidth;
189 FBevelTop := Max((FTextExtent.cy - FBevelHeight) div 2, 0);
190 end;
191
192 procedure TDividerBevel.Paint;
193 var
194 aBevel: TGraphicsBevelCut;
195 aHorizontal: Boolean;
196 PaintRect: TRect;
197 aStyle: TGrabStyle;
198
199 procedure PaintBevel;
200 var aDetails: TThemedElementDetails;
201 aRect: TRect;
202 w, l: Integer;
203 begin
204 case aStyle of
205 gsSimple: Canvas.Frame3D(PaintRect, 1, aBevel);
206 gsDouble: if aHorizontal then begin
207 aRect.TopLeft := PaintRect.TopLeft;
208 aRect.Right := PaintRect.Right;
209 w := (PaintRect.Bottom - PaintRect.Top - 2) div 2;
210 aRect.Bottom := aRect.Top + w;
211 Canvas.Frame3D(aRect, 1, aBevel);
212 aRect.Left := PaintRect.Left;
213 aRect.Top := PaintRect.Bottom - w;
214 aRect.BottomRight := PaintRect.BottomRight;
215 Canvas.Frame3D(aRect, 1, aBevel);
216 end else begin
217 aRect.TopLeft := PaintRect.TopLeft;
218 w := (PaintRect.Right - PaintRect.Left - 2) div 2;
219 aRect.Right := aRect.Left + w;
220 aRect.Bottom := PaintRect.Bottom;
221 Canvas.Frame3D(aRect, 1, aBevel);
222 aRect.Left := PaintRect.Right - w;
223 aRect.Top := PaintRect.Top;
224 aRect.BottomRight := PaintRect.BottomRight;
225 Canvas.Frame3D(aRect, 1, aBevel);
226 end;
227 gsHorLines: begin
228 aRect.TopLeft := PaintRect.TopLeft;
229 aRect.Right := PaintRect.Right;
230 l := (PaintRect.Bottom - aRect.Top + 1) div 3;
231 inc(aRect.Top);
232 Canvas.Pen.Color := clBtnShadow;
233 for w := 0 to l - 1 do
234 Canvas.Line(aRect.Left, aRect.Top + w * 3, aRect.Right, aRect.Top + w * 3);
235 Canvas.Pen.Color := clBtnHighlight;
236 inc(aRect.Top);
237 for w := 0 to l - 1 do
238 Canvas.Line(aRect.Left, aRect.Top + w * 3, aRect.Right, aRect.Top + w * 3);
239 end;
240 gsVerLines: begin
241 aRect.TopLeft := PaintRect.TopLeft;
242 l := (PaintRect.Right - aRect.Left + 1) div 3;
243 aRect.Bottom := PaintRect.Bottom + 1;
244 inc(aRect.Left);
245 Canvas.Pen.Color := clBtnShadow;
246 for w := 0 to l - 1 do
247 Canvas.Line(aRect.Left + w * 3, aRect.Top, aRect.Left + w * 3, aRect.Bottom);
248 Canvas.Pen.Color := clBtnHighlight;
249 inc(aRect.Left);
250 for w := 0 to l - 1 do
251 Canvas.Line(aRect.Left + w * 3, aRect.Top, aRect.Left + w * 3, aRect.Bottom);
252 end;
253 gsGripper: begin
254 if aHorizontal then
255 aDetails := ThemeServices.GetElementDetails(trGripper)
256 else
257 aDetails := ThemeServices.GetElementDetails(trGripperVert);
258 ThemeServices.DrawElement(Canvas.Handle, aDetails, PaintRect);
259 end;
260 gsButton: begin
261 aDetails := ThemeServices.GetElementDetails(tbPushButtonNormal);
262 ThemeServices.DrawElement(Canvas.Handle, aDetails, PaintRect);
263 end;
264 end;
265 end;
266
267 var
268 aIndent, aRight, j: Integer;
269 begin
270 CalcSize;
271 if not FTransparent then begin
272 Canvas.Brush.Color := Color;
273 Canvas.Brush.Style := bsSolid;
274 Canvas.FillRect(ClientRect);
275 end;
276
277 if FBevelStyle = bsLowered then
278 aBevel := bvLowered
279 else
280 aBevel := bvRaised;
281 aHorizontal := (Orientation = trHorizontal);
282
283 aStyle := Style;
284 if not aHorizontal then
285 case aStyle of
286 gsHorLines: aStyle := gsVerLines;
287 gsVerLines: aStyle := gsHorLines;
288 end;
289
290 if aHorizontal then begin
291 PaintRect.Left := 0;
292 PaintRect.Top := FBevelTop;
293 PaintRect.Bottom := PaintRect.Top + FBevelHeight;
294 end else begin
295 PaintRect.Left := FBevelTop;
296 PaintRect.Top := 0;
297 PaintRect.Right := PaintRect.Left + FBevelHeight;
298 end;
299
300 if Caption = '' then begin
301 if aHorizontal then
302 PaintRect.Right := Width
303 else
304 PaintRect.Bottom := Height;
305 PaintBevel;
306 exit;
307 end;
308
309 if FLeftIndent > 0 then
310 aIndent := FLeftIndent
311 else
312 if FLeftIndent = 0 then
313 aIndent := 0
314 else begin
315 j := 2*FCaptionSpacing + FTextExtent.cx;
316 if aHorizontal then
317 aIndent := (Width - j) div 2
318 else
319 aIndent := (Height - j) div 2;
320 end;
321
322 if not IsRightToLeft or not aHorizontal then
323 aRight := aIndent
324 else begin
325 aRight := Width - FTextExtent.cx - FCaptionSpacing - aIndent;
326 if aIndent > 0 then dec(aRight, FCaptionSpacing);
327 end;
328 if aRight > 0 then begin
329 if aHorizontal then
330 PaintRect.Right := aRight
331 else
332 PaintRect.Bottom := aRight;
333 PaintBevel;
334 end;
335
336 if aIndent > 0 then inc(aIndent, FCaptionSpacing);
337 if aHorizontal then begin
338 PaintRect.Left := aRight + FCaptionSpacing + FTextExtent.cx;
339 if aIndent <> 0 then inc(PaintRect.Left, FCaptionSpacing);
340 PaintRect.Top := FBevelTop;
341 PaintRect.Right := Width;
342 PaintRect.Bottom := FBevelTop + FBevelHeight;
343 end else begin
344 PaintRect.Left := FBevelTop;
345 PaintRect.Top := aRight + FCaptionSpacing + FTextExtent.cx;
346 if aIndent <> 0 then inc(PaintRect.Top, FCaptionSpacing);
347 PaintRect.Right := FBevelTop + FBevelHeight;
348 PaintRect.Bottom := Height;
349 end;
350 PaintBevel;
351
352 Canvas.Brush.Style := bsClear;
353 j := Max((FBevelHeight - FTextExtent.cy) div 2, 0);
354 if aHorizontal then begin
355 Canvas.Font.Orientation := 0;
356 if not IsRightToLeft then
357 Canvas.TextOut(aIndent, j, Caption)
358 else
359 Canvas.TextOut(Width - FTextExtent.cx - aIndent, j, Caption);
360 end else begin
361 Canvas.Font.Orientation := 900;
362 Canvas.TextOut(j, aIndent + FTextExtent.cx, Caption);
363 end;
364 end;
365
366 procedure TDividerBevel.FontChanged(Sender: TObject);
367 begin
368 inherited FontChanged(Sender);
369 FNeedCalcSize := True;
370 Invalidate;
371 end;
372
373 procedure TDividerBevel.SetAutoSize(Value: Boolean);
374 begin
375 inherited SetAutoSize(Value);
376 if Value then begin
377 InvalidatePreferredSize;
378 AdjustSize;
379 end;
380 end;
381
382 procedure TDividerBevel.TextChanged;
383 begin
384 inherited TextChanged;
385 FNeedCalcSize := True;
386 Invalidate;
387 end;
388
389 procedure TDividerBevel.CalculatePreferredSize(var PreferredWidth, PreferredHeight: Integer;
390 WithThemeSpace: Boolean);
391 begin
392 FNeedCalcSize := True;
393 CalcSize;
394 if Orientation = trHorizontal then begin
395 PreferredHeight := Max(FTextExtent.cy, FBevelHeight);
396 PreferredWidth := 0;
397 end else begin
398 PreferredHeight := 0;
399 PreferredWidth := Max(FTextExtent.cy, FBevelHeight);
400 end;
401 end;
402
403 procedure TDividerBevel.ShouldAutoAdjust(var AWidth,
404 AHeight: Boolean);
405 begin
406 AWidth := not (AutoSize and (Orientation = trVertical));
407 AHeight := not (AutoSize and (Orientation = trHorizontal));
408 end;
409
410 constructor TDividerBevel.Create(AOwner: TComponent);
411 begin
412 inherited Create(AOwner);
413 FBevelStyle := bsLowered;
414 FBevelWidth := -1;
415 FCaptionSpacing := 10;
416 FLeftIndent := 60;
417 FOrientation := trHorizontal;
418 FTransparent := True;
419 FNeedCalcSize := True;
420 if (AOwner = nil) or not (csLoading in AOwner.ComponentState) then
421 Font.Style := Font.Style + [fsBold];
422 with GetControlClassDefaultSize do
423 SetInitialBounds(0, 0, CX, CY);
424 AutoSize := True;
425 end;
426
427 end.
428
429