1 // SPDX-License-Identifier: LGPL-3.0-only (modified to allow linking)
2 {
3 Created by BGRA Controls Team
4 Dibo, Circular, lainz (007) and contributors.
5 For detailed information see readme.txt
6
7 Site: https://sourceforge.net/p/bgra-controls/
8 Wiki: http://wiki.lazarus.freepascal.org/BGRAControls
9 Forum: http://forum.lazarus.freepascal.org/index.php/board,46.0.html
10 }
11 {******************************* CONTRIBUTOR(S) ******************************
12 - Edivando S. Santos Brasil | mailedivando@gmail.com
13 (Compatibility with delphi VCL 11/2018)
14
15 ***************************** END CONTRIBUTOR(S) *****************************}
16 unit BCTrackbarUpdown;
17
18 {$I bgracontrols.inc}
19
20 interface
21
22 uses
23 {$IFDEF FPC}LCLType, LResources,{$ENDIF}
24 Classes, SysUtils, Types, Forms, Controls, Graphics, Dialogs,
25 {$IFNDEF FPC}BGRAGraphics, GraphType, FPImage, {$ENDIF}
26 ExtCtrls, BGRABitmap, BCBaseCtrls, BCTypes;
27
28 type
29 TTrackBarUpDownChangeEvent = procedure(Sender: TObject; AByUser: boolean) of object;
30
31 { TCustomBCTrackbarUpdown }
32
33 TCustomBCTrackbarUpdown = class(TBCCustomControl)
34 protected
35 FHandlingUserInput: boolean;
36 FLongTimeInterval,FShortTimeInterval: integer;
37 FMinValue,FMaxValue,FIncrement,FValue: integer;
38 FAllowNegativeValues: boolean;
39 FStartNegativeValue: boolean;
40 FBarExponent: single;
41 FSelStart,FSelLength: integer;
42 FEmptyText: boolean;
43 FBarClick,FUpClick,FDownClick: boolean;
44
45 FTimer: TTimer;
46 FOnChange: TTrackBarUpDownChangeEvent;
47 FBCBorder: TBCBorder;
48 FBCRounding: TBCRounding;
49 FBCBackground: TBCBackground;
50 FBCButtonBackground,FBCButtonDownBackground: TBCBackground;
51 FArrowColor: TColor;
52 FHasTrackBar: boolean;
53
54 FCanvasScaling: double;
55 FTextLeft: Integer;
56 FBarLeft,FBarTop,FBarWidth,FBarHeight: Integer;
57 FUpDownWidth: Integer;
58 FUpDownLeft: Integer;
59 FDownButtonTop: integer;
GetValuenull60 function GetValue: integer;
61 procedure SetAllowNegativeValues(AValue: boolean);
62 procedure SetArrowColor(AValue: TColor);
63 procedure SetHasTrackBar(AValue: boolean);
64 procedure SetBarExponent(AValue: single);
65 procedure SetBCBackground(AValue: TBCBackground);
66 procedure SetBCBorder(AValue: TBCBorder);
67 procedure SetBCButtonBackground(AValue: TBCBackground);
68 procedure SetBCButtonDownBackground(AValue: TBCBackground);
69 procedure SetBCRounding(AValue: TBCRounding);
70 procedure OnChangeProperty({%H-}Sender: TObject; {%H-}AData: PtrInt);
71 procedure Timer({%H-}Sender: TObject);
72 procedure RenderOnBitmap(ABitmap: TBGRABitmap);
73 procedure DrawControl; override;
74 procedure DoSelectAll;
GetTextnull75 function GetText: string; virtual;
76 procedure SetText(AValue: string); virtual;
77 procedure EnabledChanged; override;
78 procedure NotifyChange; virtual;
79 procedure SetIncrement(AValue: integer);
80 procedure SetMaxValue(AValue: integer);
81 procedure SetMinValue(AValue: integer);
82 procedure SetValue(AValue: integer);
ValueToBarPosnull83 function ValueToBarPos(AValue: integer): integer;
BarPosToValuenull84 function BarPosToValue(ABarPos: integer): integer;
85 procedure MouseDown(Button: TMouseButton; {%H-}Shift: TShiftState; X, Y: Integer); override;
86 procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
87 procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
DoMouseWheelnull88 function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;
89 procedure UTF8KeyPress(var UTF8Key: {$IFDEF FPC}TUTF8Char{$ELSE}String{$ENDIF}); override;
90 procedure DoEnter; override;
91 procedure DoExit; override;
92 public
93 constructor Create(AOwner: TComponent); override;
94 procedure SelectAll;
RemoveSelectionnull95 function RemoveSelection: boolean; //returns True if there was a selection to be removed
96 procedure DelayTimer; //use after the program has been busy updating something according to the value of this component
97 procedure SetFocus; override;
98 destructor Destroy; override;
99 property Border: TBCBorder read FBCBorder write SetBCBorder;
100 property Background: TBCBackground read FBCBackground write SetBCBackground;
101 property ButtonBackground: TBCBackground read FBCButtonBackground write SetBCButtonBackground;
102 property ButtonDownBackground: TBCBackground read FBCButtonDownBackground write SetBCButtonDownBackground;
103 property Rounding: TBCRounding read FBCRounding write SetBCRounding;
104 property ArrowColor: TColor read FArrowColor write SetArrowColor;
105 property HasTrackBar: boolean read FHasTrackBar write SetHasTrackBar;
106
107 property AllowNegativeValues: boolean read FAllowNegativeValues write SetAllowNegativeValues;
108 property BarExponent: single read FBarExponent write SetBarExponent;
109 property Increment: integer read FIncrement write SetIncrement;
110 property LongTimeInterval: integer read FLongTimeInterval write FLongTimeInterval;
111 property MinValue: integer read FMinValue write SetMinValue;
112 property MaxValue: integer read FMaxValue write SetMaxValue;
113 property OnChange: TTrackBarUpDownChangeEvent read FOnChange write FOnChange;
114 property Text: string read GetText write SetText;
115 property Value: integer read GetValue write SetValue;
116 property SelStart: integer read FSelStart;
117 property SelLength: integer read FSelLength;
118 property ShortTimeInterval: integer read FShortTimeInterval write FShortTimeInterval;
119 end;
120
121 TBCTrackbarUpdown = class(TCustomBCTrackbarUpdown)
122 published
123 property AllowNegativeValues;
124 property BarExponent;
125 property Increment;
126 property LongTimeInterval;
127 property MinValue;
128 property MaxValue;
129 property OnChange;
130 property Value;
131 property SelStart;
132 property SelLength;
133 property ShortTimeInterval;
134 property Background;
135 property ButtonBackground;
136 property ButtonDownBackground;
137 property Border;
138 property Rounding;
139 property Font;
140 property HasTrackBar;
141 property ArrowColor;
142
143 //inherited
144 property Align;
145 property Anchors;
146 property BorderSpacing;
147 property ChildSizing;
148 {$IFDEF FPC} //#
149 property OnGetDockCaption;
150 {$ENDIF}
151 property ClientHeight;
152 property ClientWidth;
153 property Constraints;
154 property DockSite;
155 property DragCursor;
156 property DragKind;
157 property DragMode;
158 property Enabled;
159 property ParentShowHint;
160 property PopupMenu;
161 property ShowHint;
162 property TabOrder;
163 property TabStop;
164 property UseDockManager default True;
165 property Visible;
166 property OnClick;
167 property OnContextPopup;
168 property OnDockDrop;
169 property OnDockOver;
170 property OnDblClick;
171 property OnDragDrop;
172 property OnDragOver;
173 property OnEndDock;
174 property OnEndDrag;
175 property OnEnter;
176 property OnExit;
177 property OnGetSiteInfo;
178 property OnMouseDown;
179 property OnMouseEnter;
180 property OnMouseLeave;
181 property OnMouseMove;
182 property OnMouseUp;
183 property OnResize;
184 property OnStartDock;
185 property OnStartDrag;
186 property OnUnDock;
187 end;
188
189 {$IFDEF FPC}procedure Register;{$ENDIF}
190
191 implementation
192
193 uses BGRABitmapTypes, Math, BCTools;
194
195 {$IFDEF FPC}
196 procedure Register;
197 begin
198 //{$I icons\bctrackbarupdown_icon.lrs}
199 RegisterComponents('BGRA Controls', [TBCTrackbarUpdown]);
200 end;
201 {$ENDIF}
202
203 { TCustomBCTrackbarUpdown }
204
TCustomBCTrackbarUpdown.GetTextnull205 function TCustomBCTrackbarUpdown.GetText: string;
206 begin
207 if FEmptyText then
208 begin
209 if FStartNegativeValue then
210 result := '-'
211 else
212 result := '';
213 end else
214 result := IntToStr(FValue);
215 end;
216
217 procedure TCustomBCTrackbarUpdown.SetText(AValue: string);
218 var errPos,tempValue: integer;
219 txt: string;
220 prevActualValue: integer;
221 begin
222 if trim(AValue) = '' then
223 begin
224 if not FEmptyText or FStartNegativeValue then
225 begin
226 FEmptyText:= true;
227 FStartNegativeValue:= false;
228 Invalidate;
229 end;
230 exit;
231 end;
232 prevActualValue:= Value;
233 val(AValue,tempValue,errPos);
234 if errPos = 0 then
235 begin
236 if tempValue > FMaxValue then tempValue := FMaxValue;
237 if (tempValue < 0) and (tempValue < FMinValue) then tempValue:= FMinValue;
238 if (FValue = tempValue) and not FEmptyText then exit;
239 FValue := tempValue;
240 FEmptyText:= false;
241 end else
242 if (AValue = '-') and AllowNegativeValues then
243 begin
244 FEmptyText:= true;
245 FStartNegativeValue:= true;
246 end;
247 txt := Text;
248 if FSelStart > length(txt) then FSelStart := length(txt);
249 if FSelStart+FSelLength > length(txt) then FSelLength:= length(txt)-FSelStart;
250 Repaint;
251 if Value <> prevActualValue then NotifyChange;
252 end;
253
254 procedure TCustomBCTrackbarUpdown.EnabledChanged;
255 begin
256 inherited EnabledChanged;
257 Invalidate;
258 end;
259
260 procedure TCustomBCTrackbarUpdown.NotifyChange;
261 begin
262 if Assigned(FOnChange) then FOnChange(self, FHandlingUserInput);
263 end;
264
265 procedure TCustomBCTrackbarUpdown.SetIncrement(AValue: integer);
266 begin
267 if FIncrement=AValue then Exit;
268 FIncrement:=AValue;
269 end;
270
271 procedure TCustomBCTrackbarUpdown.SetMaxValue(AValue: integer);
272 begin
273 if not AllowNegativeValues and (AValue < 0) then AValue := 0;
274 if FMaxValue=AValue then Exit;
275 FMaxValue:=AValue;
276 if FMaxValue < FMinValue then FMinValue := FMaxValue;
277 if AValue > FMaxValue then FMaxValue:= AValue;
278 Invalidate;
279 end;
280
281 procedure TCustomBCTrackbarUpdown.SetMinValue(AValue: integer);
282 begin
283 if not AllowNegativeValues and (AValue < 0) then AValue := 0;
284 if FMinValue=AValue then Exit;
285 FMinValue:=AValue;
286 if FMinValue > FMaxValue then FMaxValue := FMinValue;
287 if AValue < FMinValue then FMinValue:= AValue;
288 Invalidate;
289 end;
290
291 procedure TCustomBCTrackbarUpdown.SetValue(AValue: integer);
292 begin
293 if AValue < FMinValue then AValue := FMinValue;
294 if AValue > FMaxValue then AValue := FMaxValue;
295 if FValue=AValue then Exit;
296 FValue:=AValue;
297 FEmptyText:= false;
298 DoSelectAll;
299 Invalidate;
300 NotifyChange;
301 end;
302
303 procedure TCustomBCTrackbarUpdown.SetArrowColor(AValue: TColor);
304 begin
305 if FArrowColor=AValue then Exit;
306 FArrowColor:=AValue;
307 Invalidate;
308 end;
309
310 procedure TCustomBCTrackbarUpdown.SetHasTrackBar(AValue: boolean);
311 begin
312 if FHasTrackBar=AValue then Exit;
313 FHasTrackBar:=AValue;
314 Invalidate;
315 end;
316
317 procedure TCustomBCTrackbarUpdown.SetAllowNegativeValues(AValue: boolean);
318 var
319 changeVal: Boolean;
320 begin
321 if FAllowNegativeValues=AValue then Exit;
322 FAllowNegativeValues:=AValue;
323 if not FAllowNegativeValues then
324 begin
325 if (FMinValue < 0) or (FValue < 0) or (FMaxValue < 0) then
326 begin
327 if FMinValue < 0 then FMinValue := 0;
328 if FValue < 0 then
329 begin
330 FValue := 0;
331 changeVal := true;
332 end else changeVal := false;
333 if FMaxValue < 0 then FMaxValue:= 0;
334 Invalidate;
335 if changeVal then NotifyChange;
336 end;
337 end;
338 end;
339
TCustomBCTrackbarUpdown.GetValuenull340 function TCustomBCTrackbarUpdown.GetValue: integer;
341 begin
342 if FValue < FMinValue then result := FMinValue else
343 result := FValue;
344 end;
345
346 procedure TCustomBCTrackbarUpdown.SetBarExponent(AValue: single);
347 begin
348 if AValue <= 0 then exit;
349 if FBarExponent=AValue then Exit;
350 FBarExponent:=AValue;
351 Invalidate;
352 end;
353
354 procedure TCustomBCTrackbarUpdown.SetBCBackground(AValue: TBCBackground);
355 begin
356 if FBCBackground=AValue then Exit;
357 FBCBackground.Assign(AValue);
358 end;
359
360 procedure TCustomBCTrackbarUpdown.SetBCBorder(AValue: TBCBorder);
361 begin
362 if FBCBorder=AValue then Exit;
363 FBCBorder.Assign(AValue);
364 end;
365
366 procedure TCustomBCTrackbarUpdown.SetBCButtonBackground(AValue: TBCBackground);
367 begin
368 if FBCButtonBackground=AValue then Exit;
369 FBCButtonBackground.Assign(AValue);
370 end;
371
372 procedure TCustomBCTrackbarUpdown.SetBCButtonDownBackground(
373 AValue: TBCBackground);
374 begin
375 if FBCButtonDownBackground=AValue then Exit;
376 FBCButtonDownBackground.Assign(AValue);
377 end;
378
379 procedure TCustomBCTrackbarUpdown.SetBCRounding(AValue: TBCRounding);
380 begin
381 if FBCRounding=AValue then Exit;
382 FBCRounding.Assign(AValue);
383 end;
384
385 procedure TCustomBCTrackbarUpdown.OnChangeProperty(Sender: TObject;
386 AData: PtrInt);
387 begin
388 RenderControl;
389 Invalidate;
390 end;
391
392 procedure TCustomBCTrackbarUpdown.Timer(Sender: TObject);
393 begin
394 FHandlingUserInput:= true;
395 if FUpClick then
396 begin
397 Value := Value + Increment;
398 end else
399 if FDownClick then
400 Value := Value - Increment;
401 FHandlingUserInput:= false;
402 FTimer.Interval := ShortTimeInterval;
403 end;
404
405 procedure TCustomBCTrackbarUpdown.RenderOnBitmap(ABitmap: TBGRABitmap);
406 var bordercolor,fgcolor,btntext: TBGRAPixel;
407 x,y,ty,barx: integer;
408 s: TSize;
409 midy: integer;
410 midx: single;
411 beforeSel,inSel,afterSel: string;
412 bounds,fullBounds: TRect;
413 begin
414 fullbounds := rect(0,0,ABitmap.Width,ABitmap.Height);
415 bounds := fullBounds;
416 CalculateInnerRect(Border, bounds);
417 ty := bounds.bottom-bounds.top-2;
418 FTextLeft := bounds.left+1+((ty+5) div 10);
419 FUpDownWidth := (ty*3+3) div 5;
420 FUpDownLeft := bounds.right-FUpDownWidth;
421
422 FBarLeft := bounds.left+1;
423 if FHasTrackBar then
424 begin
425 FBarHeight := (bounds.bottom-bounds.top+3) div 5+1;
426 FBarWidth := bounds.right-FUpDownWidth-FBarHeight+1-FBarLeft;
427 if (Rounding.RoundX > 1) and (Rounding.RoundY > 1) then
428 FBarLeft := FBarLeft +FBarHeight+1;
429 end else
430 begin
431 FBarWidth := 0;
432 FBarHeight := 2;
433 end;
434 FBarTop := bounds.bottom-FBarHeight;
435
436 midy := ABitmap.Height div 2;
437 FDownButtonTop := midy;
438
439 ABitmap.ClipRect := rect(fullbounds.left,fullbounds.top,FUpDownLeft+1,fullbounds.bottom);
440 RenderBackgroundAndBorder(fullbounds, Background, ABitmap, Rounding, Border);
441
442 bordercolor := ColorToBGRA(ColorToRGB(Border.Color),Border.ColorOpacity);
443 ABitmap.VertLine(FUpDownLeft,bounds.top,bounds.bottom-1,bordercolor,dmDrawWithTransparency);
444
445 if FUpClick then
446 begin
447 ABitmap.ClipRect := rect(FUpDownLeft+1,fullbounds.top,fullbounds.Right,midy);
448 RenderBackgroundAndBorder(fullbounds, ButtonDownBackground, ABitmap, Rounding, Border);
449 ABitmap.ClipRect := rect(FUpDownLeft+1,midy,fullbounds.Right,fullbounds.bottom);
450 RenderBackgroundAndBorder(fullbounds, ButtonBackground, ABitmap, Rounding, Border);
451 end else
452 if FDownClick then
453 begin
454 ABitmap.ClipRect := rect(FUpDownLeft+1,fullbounds.top,fullbounds.Right,midy+1);
455 RenderBackgroundAndBorder(fullbounds, ButtonBackground, ABitmap, Rounding, Border);
456 ABitmap.ClipRect := rect(FUpDownLeft+1,midy+1,fullbounds.Right,fullbounds.bottom);
457 RenderBackgroundAndBorder(fullbounds, ButtonDownBackground, ABitmap, Rounding, Border);
458 end else
459 begin
460 ABitmap.ClipRect := rect(FUpDownLeft+1,fullbounds.top,fullbounds.Right,fullbounds.bottom);
461 RenderBackgroundAndBorder(fullbounds, ButtonBackground, ABitmap, Rounding, Border);
462 end;
463 ABitmap.NoClip;
464 ABitmap.HorizLine(FUpDownLeft+1,midy,bounds.right-1,bordercolor,dmDrawWithTransparency);
465
466 ABitmap.FontQuality := fqFineAntialiasing;
467 ABitmap.FontName := Font.Name;
468 ABitmap.FontStyle := Font.Style;
469 ABitmap.FontHeight := ((ty-FBarHeight+1)*8+4) div 9;
470 fgcolor := Font.Color;
471
472 x := FTextLeft;
473 y := bounds.top+1;
474 if Focused then
475 begin
476 if SelStart = 0 then
477 begin
478 beforeSel := '';
479 inSel := Text;
480 end else
481 begin
482 beforeSel := copy(Text,1,SelStart);
483 inSel := copy(Text,SelStart+1,length(Text)-SelStart);
484 end;
485 if length(inSel)>SelLength then
486 begin
487 afterSel:= copy(inSel,SelLength+1,length(inSel)-SelLength);
488 inSel := copy(inSel,1,SelLength);
489 end else
490 afterSel := '';
491 ABitmap.TextOut(x,y,beforeSel,fgcolor);
492 inc(x, ABitmap.TextSize(beforeSel).cx);
493 if inSel = '' then ABitmap.SetVertLine(x,y,y+ABitmap.FontFullHeight-1,fgcolor)
494 else
495 begin
496 s := ABitmap.TextSize(inSel);
497 ABitmap.FillRect(x,y+1,x+s.cx,y+s.cy,ColorToRGB(clHighlight),dmSet);
498 ABitmap.TextOut(x,y,inSel,ColorToRGB(clHighlightText));
499 inc(x,s.cx);
500 end;
501 ABitmap.TextOut(x,y,afterSel,fgcolor);
502 end else
503 begin
504 if Enabled then
505 ABitmap.TextOut(x,y,Text,fgcolor)
506 else
507 ABitmap.TextOut(x,y,Text,BGRA(fgcolor.red,fgcolor.green,fgcolor.blue,fgcolor.alpha div 2));
508 end;
509
510 barx := ValueToBarPos(Value);
511 if FHasTrackBar then
512 ABitmap.FillPolyAntialias([PointF(barx,FBarTop),PointF(barx+FBarHeight,FBarTop+FBarHeight),
513 PointF(barx-FBarHeight,FBarTop+FBarHeight)],fgcolor);
514 midx := FUpDownLeft+(FUpDownWidth-1)/2;
515 btntext := FArrowColor;
516 ABitmap.FillPolyAntialias([PointF(FUpDownLeft+2,midy*4/5),PointF(midx,midy/5),PointF(FUpDownLeft+FUpDownWidth-3,midy*4/5)],btntext);
517 ABitmap.FillPolyAntialias([PointF(FUpDownLeft+2,midy*6/5),PointF(midx,ABitmap.Height-midy/5),PointF(FUpDownLeft+FUpDownWidth-3,midy*6/5)],btntext);
518 end;
519
TCustomBCTrackbarUpdown.ValueToBarPosnull520 function TCustomBCTrackbarUpdown.ValueToBarPos(AValue: integer): integer;
521 var t: single;
522 begin
523 if FMaxValue>FMinValue then
524 begin
525 t := (AValue-FMinValue)/(FMaxValue-FMinValue);
526 if t < 0 then t := 0;
527 if t > 1 then t := 1;
528 result := FBarLeft+round(power(t,1/FBarExponent)*(FBarWidth-1))
529 end
530 else
531 result := FBarLeft;
532 end;
533
BarPosToValuenull534 function TCustomBCTrackbarUpdown.BarPosToValue(ABarPos: integer): integer;
535 var t: single;
536 begin
537 if FBarWidth > FBarLeft then
538 begin
539 t := (ABarPos-FBarLeft)/(FBarWidth-1);
540 if t < 0 then t := 0;
541 if t > 1 then t := 1;
542 result := round(power(t,FBarExponent)*(FMaxValue-FMinValue))+FMinValue
543 end
544 else
545 result := FMinValue;
546 end;
547
548 procedure TCustomBCTrackbarUpdown.MouseDown(Button: TMouseButton;
549 Shift: TShiftState; X, Y: Integer);
550 begin
551 X := round(X*FCanvasScaling);
552 Y := round(Y*FCanvasScaling);
553 if Button = mbLeft then
554 begin
555 FHandlingUserInput:= true;
556 if X >= FUpDownLeft then
557 begin
558 if Y > FDownButtonTop then
559 begin
560 FDownClick:= true;
561 Value := Value-Increment;
562 Invalidate;
563 FTimer.Interval := LongTimeInterval;
564 FTimer.Enabled:= true;
565 end else
566 if Y < FDownButtonTop then
567 begin
568 FUpClick:= true;
569 Value := Value+Increment;
570 Invalidate;
571 FTimer.Interval := LongTimeInterval;
572 FTimer.Enabled:= true;
573 end;
574 end else
575 if (Y >= Height-FBarHeight-1) and (FBarWidth>1) then
576 begin
577 FBarClick:= true;
578 Value := BarPosToValue(X);
579 Repaint;
580 end;
581 FHandlingUserInput:= false;
582 end;
583 if not Focused then
584 begin
585 SetFocus;
586 SelectAll;
587 end;
588 end;
589
590 procedure TCustomBCTrackbarUpdown.MouseMove(Shift: TShiftState; X, Y: Integer);
591 begin
592 inherited MouseMove(Shift, X, Y);
593 X := round(X*FCanvasScaling);
594 Y := round(Y*FCanvasScaling);
595 if FBarClick and (FBarWidth>1) then
596 begin
597 FHandlingUserInput:= true;
598 Value := BarPosToValue(X);
599 FHandlingUserInput:= false;
600 end;
601 end;
602
603 procedure TCustomBCTrackbarUpdown.MouseUp(Button: TMouseButton;
604 Shift: TShiftState; X, Y: Integer);
605 begin
606 inherited MouseUp(Button, Shift, X, Y);
607 X := round(X*FCanvasScaling);
608 Y := round(Y*FCanvasScaling);
609 if Button = mbLeft then
610 begin
611 if FBarClick then FBarClick:= false else
612 if FUpClick then
613 begin
614 FUpClick:= false;
615 Invalidate;
616 FTimer.Enabled:= false;
617 end else
618 if FDownClick then
619 begin
620 FDownClick:= false;
621 Invalidate;
622 FTimer.Enabled:= false;
623 end;
624 end;
625 end;
626
DoMouseWheelnull627 function TCustomBCTrackbarUpdown.DoMouseWheel(Shift: TShiftState;
628 WheelDelta: Integer; MousePos: TPoint): Boolean;
629 begin
630 if Assigned(OnMouseWheel) or Assigned(OnMouseWheelDown) or Assigned(OnMouseWheelUp) then
631 begin
632 result := inherited DoMouseWheel(Shift, WheelDelta, MousePos);
633 exit;
634 end;
635 FHandlingUserInput:= true;
636 Value := Value + Increment*WheelDelta div 120;
637 FHandlingUserInput := false;
638 Invalidate;
639 result := true;
640 end;
641
642 procedure TCustomBCTrackbarUpdown.UTF8KeyPress(var UTF8Key: {$IFDEF FPC}TUTF8Char{$ELSE}String{$ENDIF});
643 var tempText: string;
644 begin
645 FHandlingUserInput:= true;
646 if UTF8Key = #8 then
647 begin
648 if not RemoveSelection and (SelStart > 0) then
649 begin
650 tempText := Text;
651 Dec(FSelStart);
652 Delete(tempText,SelStart+1,1);
653 Text := tempText;
654 Invalidate;
655 end;
656 UTF8Key:= #0;
657 end else
658 if (length(UTF8Key)=1) and ((UTF8Key[1] in['0'..'9']) or ((UTF8Key[1]='-') and (SelStart = 0))) then
659 begin
660 RemoveSelection;
661 tempText := Text;
662 Insert(UTF8Key,tempText,SelStart+1);
663 Text := tempText;
664 if FSelStart < length(Text) then inc(FSelStart);
665 Invalidate;
666 UTF8Key:= #0;
667 end;
668 FHandlingUserInput:= false;
669 end;
670
671 procedure TCustomBCTrackbarUpdown.DoEnter;
672 begin
673 inherited DoEnter;
674 Invalidate;
675 end;
676
677 procedure TCustomBCTrackbarUpdown.DoExit;
678 begin
679 inherited DoExit;
680 if FValue > FMaxValue then FValue := FMaxValue;
681 if FValue < FMinValue then FValue := FMinValue;
682 if FEmptyText then
683 begin
684 FEmptyText:= false;
685 SelectAll;
686 end;
687 Invalidate;
688 end;
689
690 procedure TCustomBCTrackbarUpdown.DrawControl;
691 var bmp: TBGRABitmap;
692 begin
693 FCanvasScaling:= GetCanvasScaleFactor;
694 bmp := TBGRABitmap.Create(round(Width*FCanvasScaling),round(Height*FCanvasScaling));
695 RenderOnBitmap(bmp);
696 bmp.Draw(Canvas,rect(0,0,Width,Height),False);
697 bmp.Free;
698 end;
699
700 constructor TCustomBCTrackbarUpdown.Create(AOwner: TComponent);
701 begin
702 inherited Create(AOwner);
703 with GetControlClassDefaultSize do
704 SetInitialBounds(0, 0, CX, CY);
705 FMinValue:= 0;
706 FMaxValue := 100;
707 FValue := 50;
708 FIncrement := 1;
709 FBarExponent:= 1;
710 FCanvasScaling:= 1;
711 FTimer := TTimer.Create(self);
712 FTimer.Enabled := false;
713 FTimer.OnTimer:=Timer;
714 FLongTimeInterval:= 400;
715 FShortTimeInterval:= 100;
716 FHasTrackBar:= true;
717 FBCBorder := TBCBorder.Create(self);
718 FBCBorder.Color := clWindowText;
719 FBCBorder.Width := 1;
720 FBCBorder.Style := bboSolid;
721 FBCBorder.OnChange := OnChangeProperty;
722 FBCRounding := TBCRounding.Create(self);
723 FBCRounding.RoundX := 1;
724 FBCRounding.RoundY := 1;
725 FBCRounding.OnChange := OnChangeProperty;
726 FBCBackground := TBCBackground.Create(self);
727 FBCBackground.Style := bbsColor;
728 FBCBackground.Color := clWindow;
729 FBCBackground.OnChange := OnChangeProperty;
730 FBCButtonBackground := TBCBackground.Create(self);
731 FBCButtonBackground.Style := bbsGradient;
732 FBCButtonBackground.Gradient1EndPercent := 50;
733 FBCButtonBackground.Gradient1.Point1YPercent := -50;
734 FBCButtonBackground.Gradient1.Point2YPercent := 50;
735 FBCButtonBackground.Gradient1.StartColor := clBtnShadow;
736 FBCButtonBackground.Gradient1.EndColor := clBtnFace;
737 FBCButtonBackground.Gradient2.Point1YPercent := 50;
738 FBCButtonBackground.Gradient2.Point2YPercent := 150;
739 FBCButtonBackground.Gradient2.StartColor := clBtnFace;
740 FBCButtonBackground.Gradient2.EndColor := clBtnShadow;
741 FBCButtonBackground.OnChange := OnChangeProperty;
742 FBCButtonDownBackground := TBCBackground.Create(self);
743 FBCButtonDownBackground.Style := bbsColor;
744 FBCButtonDownBackground.Color := clBtnShadow;
745 FBCButtonDownBackground.OnChange := OnChangeProperty;
746 FArrowColor:= clBtnText;
747 Font.Color := clWindowText;
748 Font.Name := 'Arial';
749
750 DoSelectAll;
751 TabStop := true;
752 end;
753
754 procedure TCustomBCTrackbarUpdown.DoSelectAll;
755 begin
756 FSelStart := 0;
757 FSelLength := length(Text);
758 end;
759
760 procedure TCustomBCTrackbarUpdown.SelectAll;
761 begin
762 DoSelectAll;
763 Invalidate;
764 end;
765
TCustomBCTrackbarUpdown.RemoveSelectionnull766 function TCustomBCTrackbarUpdown.RemoveSelection: boolean;
767 var
768 tempText: string;
769 len:integer;
770 begin
771 if SelLength > 0 then
772 begin
773 tempText := Text;
774 len := FSelLength;
775 FSelLength := 0;
776 Delete(tempText,SelStart+1,len);
777 Text := tempText;
778 Invalidate;
779 result := true
780 end else
781 result := false;
782 end;
783
784 procedure TCustomBCTrackbarUpdown.DelayTimer;
785 begin
786 if FTimer.Enabled then
787 begin
788 FTimer.Enabled:= false;
789 FTimer.Enabled:= true;
790 end;
791 end;
792
793 procedure TCustomBCTrackbarUpdown.SetFocus;
794 begin
795 try
796 inherited SetFocus;
797 except
798 //in some cases, it is impossible to set the focus
799 //but that's not a reason to crash the program
800 end;
801 end;
802
803 destructor TCustomBCTrackbarUpdown.Destroy;
804 begin
805 FreeAndNil(FTimer);
806 FreeAndNil(FBCBackground);
807 FreeAndNil(FBCButtonBackground);
808 FreeAndNil(FBCButtonDownBackground);
809 FreeAndNil(FBCBorder);
810 FreeAndNil(FBCRounding);
811 inherited Destroy;
812 end;
813
814 end.
815