1{%MainUnit ../comctrls.pp} 2{ TCustomUpDown 3 4 ***************************************************************************** 5 This file is part of the Lazarus Component Library (LCL) 6 7 See the file COPYING.modifiedLGPL.txt, included in this distribution, 8 for details about the license. 9 ***************************************************************************** 10 11Problems - 12 - Doesn't draw Themed Arrows/doesn't match system colors 13 - Associate Key down and Tabbing(VK_Up, VK_Down) 14} 15Type 16 { TUpDownButton } 17 18 TUpDownButton = Class(TSpeedButton) 19 private 20 FMouseTimer : TTimer; 21 FUpDown : TCustomUpDown; 22 FButtonType : TUDBtnType; 23 protected 24 procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer 25 ); override; 26 procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 27 override; 28 procedure DblClick; override; 29 public 30 constructor CreateWithParams(UpDown : TCustomUpDown; 31 ButtonType : TUDBtnType); 32 33 procedure Click; override; 34 procedure Paint; override; 35 end; 36 37procedure TUpDownButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, 38 Y: Integer); 39begin 40 inherited MouseDown(Button, Shift, X, Y); 41 if Button = mbLeft then begin 42 With FUpDown do begin 43 FMouseTimerEvent := @Self.Click; 44 FMouseDownBounds := Bounds(Self.ClientOrigin.X, Self.ClientOrigin.Y, 45 Self.Width,Self.Height); 46 If Not Assigned(FMouseTimer) then 47 FMouseTimer := TTimer.Create(FUpDown); 48 With FMouseTimer do begin 49 Enabled := False; 50 Interval := 300; 51 OnTimer := @BTimerExec; 52 Enabled := True; 53 end; 54 end; 55 end; 56end; 57 58procedure TUpDownButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, 59 Y: Integer); 60begin 61 inherited MouseUp(Button, Shift, X, Y); 62 With FUpDown do 63 If Assigned(FMouseTimer) then begin 64 FreeAndNil(FMouseTimer); 65 FMouseDownBounds := Rect(0,0,0,0); 66 FMouseTimerEvent := nil; 67 end; 68end; 69 70procedure TUpDownButton.DblClick; 71begin 72 Click; 73end; 74 75procedure TUpDownButton.Click; 76begin 77 with FUpDown do 78 begin 79 FCanChangePos := Position; 80 FCanChangeDir := updNone; 81 82 case FButtonType of 83 btPrev : 84 begin 85 FCanChangeDir := updDown; 86 87 if FCanChangePos - Increment >= Min then 88 FCanChangePos := FCanChangePos - Increment 89 else 90 if Wrap then 91 FCanChangePos := Max + (FCanChangePos - Increment - Min) + 1 92 else 93 FCanChangePos := Min; 94 end; 95 btNext : 96 begin 97 FCanChangeDir := updUp; 98 99 if FCanChangePos + Increment <= Max then 100 FCanChangePos := FCanChangePos + Increment 101 else 102 If Wrap then 103 FCanChangePos := Min + (FCanChangePos + Increment - Max) - 1 104 else 105 FCanChangePos := Max; 106 end; 107 108 end; 109 if not CanChange then Exit; 110 Position := FCanChangePos; 111 112 Click(FButtonType); 113 end; 114end; 115 116constructor TUpDownButton.CreateWithParams(UpDown : TCustomUpDown; 117 ButtonType : TUDBtnType); 118begin 119 Inherited Create(UpDown); 120 FUpDown := UpDown; 121 FButtonType := ButtonType; 122 123 Parent := FUpDown; 124 ControlStyle := ControlStyle + [csNoFocus, csNoDesignSelectable]; 125end; 126 127procedure TUpDownButton.Paint; 128var 129 tmp : double; 130 ax, ay, ah, aw : integer; 131 j : integer; 132begin 133 Inherited Paint; 134 if Enabled then 135 Canvas.Pen.Color := clBtnText //Not perfect, but it works 136 else 137 Canvas.Pen.Color := clGrayText; 138 139 ah := height div 2; 140 aw := width div 2; 141 142 if (FUpDown.Orientation = udHorizontal) then begin 143 tmp := double(ah+1)/2; 144 if (tmp > aw) then begin 145 ah := 2*aw - 1; 146 aw := (ah+1) div 2; 147 end 148 else begin 149 aw := RoundToInt(tmp); 150 ah := 2*aw - 1; 151 end; 152 aw := max(aw, 3); 153 ah := max(ah, 5); 154 end 155 else begin 156 tmp := double(aw+1)/2; 157 158 if (tmp > ah) then begin 159 aw := 2*ah - 1; 160 ah := (aw+1) div 2; 161 end 162 else begin 163 ah := RoundToInt(tmp); 164 aw := 2*ah - 1; 165 end; 166 ah := max(ah, 3); 167 aw := max(aw, 5); 168 end; 169 170 ax := (width - aw) div 2; 171 ay := (height - ah) div 2; 172 173 Case FButtonType of 174 btPrev : 175 begin 176 If FUpDown.Orientation = udVertical then begin 177 for j := 0 to aw div 2 do begin 178 Canvas.MoveTo(ax + j, ay + j); 179 Canvas.LineTo(ax + aw - j, ay + j); 180 end; 181 end 182 else 183 for j := 0 to ah div 2 do begin 184 Canvas.MoveTo(ax + aw - j - 2, ay + j); 185 Canvas.LineTo(ax + aw - j - 2, ay + ah - j - 1); 186 end; 187 end; 188 btNext : 189 begin 190 If FUpDown.Orientation = udVertical then begin 191 for j := 0 to aw div 2 do begin 192 Canvas.MoveTo(ax + j, ay + ah - j - 1); 193 Canvas.LineTo(ax + aw - j, ay + ah - j - 1); 194 end; 195 end 196 else 197 for j := 0 to ah div 2 do begin 198 Canvas.MoveTo(ax + j, ay + j); 199 Canvas.LineTo(ax + j, ay + ah - j - 1); 200 end; 201 end 202 end; 203end; 204 205{ TCustomUpDown } 206 207constructor TCustomUpDown.Create(AOwner: TComponent); 208begin 209 inherited Create(AOwner); 210 ControlStyle := ControlStyle - [csDoubleClicks] + 211 [csClickEvents, csOpaque, csReplicatable, csNoFocus]; 212 FUseWS := IsWSComponentInheritsFrom(TCustomUpDown, TWSCustomUpDown); 213 FOrientation := udVertical; 214 215 if not FUseWS then begin 216 FMinBtn := TUpDownButton.CreateWithParams(Self, btPrev); 217 FMaxBtn := TUpDownButton.CreateWithParams(Self, btNext); 218 end; 219 with GetControlClassDefaultSize do 220 SetInitialBounds(0, 0, CX, CY); 221 FArrowKeys := True; 222 FMax := 100; 223 FMinRepeatInterval := 100; 224 FIncrement := 1; 225 FAlignButton := udRight; 226 FThousands := True; 227end; 228 229destructor TCustomUpDown.Destroy; 230begin 231 FAssociate := nil; 232 inherited destroy; 233end; 234 235procedure TCustomUpDown.BTimerExec(Sender : TObject); 236var 237 AInterval:Integer; 238begin 239 If Assigned(FMouseTimerEvent) 240 and PtInRect(FMouseDownBounds,Mouse.CursorPos) then begin 241 AInterval := TTimer(Sender).Interval; 242 if AInterval > FMinRepeatInterval then begin 243 AInterval := AInterval - 25; 244 if AInterval < FMinRepeatInterval then AInterval := FMinRepeatInterval; 245 TTimer(Sender).Interval := AInterval; 246 end; 247 FMouseTimerEvent; 248 end; 249end; 250 251procedure TCustomUpDown.UpdateUpDownPositionText; 252begin 253 if (not (csDesigning in ComponentState)) and (FAssociate <> nil) 254 then begin 255 if Thousands 256 then FAssociate.Caption := FloatToStrF(FPosition, ffNumber, 0, 0) 257 else FAssociate.Caption := IntToStr(FPosition); 258 end; 259end; 260 261class procedure TCustomUpDown.WSRegisterClass; 262begin 263 inherited WSRegisterClass; 264 RegisterCustomUpDown; 265end; 266 267procedure TCustomUpDown.InitializeWnd; 268begin 269 inherited InitializeWnd; 270 if not FUseWS then Exit; 271 TWSCustomUpDownClass(WidgetSetClass).SetMaxPosition(Self, FMax); 272 TWSCustomUpDownClass(WidgetSetClass).SetPosition(Self, FPosition); 273 TWSCustomUpDownClass(WidgetSetClass).SetIncrement(Self, FIncrement); 274 TWSCustomUpDownClass(WidgetSetClass).SetWrap(Self, FWrap); 275 TWSCustomUpDownClass(WidgetSetClass).SetOrientation(Self, FOrientation); 276 TWSCustomUpDownClass(WidgetSetClass).SetUseArrowKeys(Self, FArrowKeys); 277end; 278 279procedure TCustomUpDown.UpdateOrientation; 280var 281 d, r: Integer; 282begin 283 if FUseWS then Exit; 284 285 If FOrientation = udHorizontal then begin 286 d:=ClientWidth div 2; 287 r:=ClientWidth mod 2; 288 FMinBtn.SetBounds(0,0,d,ClientHeight); 289 FMaxBtn.SetBounds(d+r,0,d,ClientHeight); 290 end 291 else begin 292 d:=ClientHeight div 2; 293 r:=ClientHeight mod 2; 294 FMaxBtn.SetBounds(0,0,ClientWidth,d); 295 FMinBtn.SetBounds(0,d+r,ClientWidth,d); 296 end; 297end; 298 299procedure TCustomUpDown.UpdateAlignButtonPos; 300var 301 NewWidth: Integer; 302 NewLeft: Integer; 303 NewHeight: Integer; 304 NewTop: Integer; 305begin 306 If Assigned(Associate) then begin 307 if FAlignButton in [udLeft,udRight] then begin 308 NewWidth := Width; 309 NewHeight := Associate.Height; 310 If FAlignButton = udLeft then 311 NewLeft := Associate.Left - NewWidth 312 else 313 NewLeft := Associate.Left + Associate.Width; 314 NewTop := Associate.Top; 315 end else begin 316 NewWidth := Associate.Width; 317 NewHeight := Height; 318 NewLeft := Associate.Left; 319 If FAlignButton = udTop then 320 NewTop := Associate.Top - NewHeight 321 else 322 NewTop := Associate.Top + Associate.Height; 323 end; 324 SetBounds(NewLeft,NewTop,NewWidth,NewHeight); 325 end; 326end; 327 328function TCustomUpDown.CanChange: Boolean; 329begin 330 Result := True; 331 332 if Assigned(FOnChanging) then 333 FOnChanging(Self, Result); 334 335 if Assigned(FOnChangingEx) then 336 FOnChangingEx(Self, Result, FCanChangePos, FCanChangeDir); 337end; 338 339procedure TCustomUpDown.Click(Button: TUDBtnType); 340begin 341 if Assigned(FOnClick) then FOnClick(Self, Button); 342end; 343 344procedure TCustomUpDown.SetAssociate(Value: TWinControl); 345var 346 I: Integer; 347 OtherControl: TControl; 348begin 349 // check that no other updown component is associated to the new Associate 350 if (Value <> FAssociate) and (Value<>nil) then 351 for I := 0 to Parent.ControlCount - 1 do begin 352 OtherControl:=Parent.Controls[I]; 353 if (OtherControl is TCustomUpDown) and (OtherControl <> Self) then 354 if TCustomUpDown(OtherControl).Associate = Value then 355 raise Exception.CreateFmt(rsIsAlreadyAssociatedWith, 356 [Value.Name,OtherControl.Name]); 357 end; 358 359 // disconnect old Associate 360 if FAssociate <> nil then 361 begin 362 FAssociate.RemoveAllHandlersOfObject(Self); 363 FAssociate := nil; 364 end; 365 366 // connect new Associate 367 if (Value <> nil) and (Value.Parent = Self.Parent) 368 and not (Value is TCustomUpDown) and not (Value is TCustomTreeView) 369 and not (Value is TCustomListView) 370 then 371 begin 372 FAssociate := Value; 373 UpdateUpDownPositionText; 374 UpdateAlignButtonPos; 375 FAssociate.AddHandlerOnKeyDown(@AssociateKeyDown,true); 376 FAssociate.AddHandlerOnChangeBounds(@OnAssociateChangeBounds,true); 377 FAssociate.AddHandlerOnEnabledChanged(@OnAssociateChangeEnabled,true); 378 FAssociate.AddHandlerOnVisibleChanged(@OnAssociateChangeVisible,true); 379 FAssociate.AddHandlerOnMouseWheel(@AssociateMouseWheel,true); 380 end; 381end; 382 383procedure TCustomUpDown.AdjustPos(incPos: Boolean); 384var 385 anewpos: Integer; 386begin 387 if FUseWS then begin 388 if incPos then anewpos := Position + Increment 389 else anewpos := Position - Increment; 390 391 if (anewpos < Min) then anewpos := Min 392 else if (anewpos > Max) then anewpos := Max; 393 SetPosition(anewpos); 394 end else begin 395 if incPos then TCustomSpeedButton(FMaxBtn).Click 396 else TCustomSpeedButton(FMinBtn).Click; 397 end; 398 399end; 400 401procedure TCustomUpDown.AssociateKeyDown(Sender: TObject; var Key: Word; 402 ShiftState : TShiftState); 403var 404 ConsumeKey: Boolean; 405begin 406 ConsumeKey := False; 407 if ArrowKeys and (ShiftState = []) then 408 begin 409 case FOrientation of 410 udVertical: 411 case Key of 412 VK_Up: 413 begin 414 AdjustPos(True); 415 ConsumeKey := True; 416 end; 417 VK_Down: 418 begin 419 AdjustPos(False); 420 ConsumeKey := True; 421 end; 422 end; 423 udHorizontal: 424 case Key of 425 VK_Left: 426 begin 427 AdjustPos(False); 428 ConsumeKey := True; 429 end; 430 VK_Right: 431 begin 432 AdjustPos(True); 433 ConsumeKey := True; 434 end; 435 end; 436 end; 437 end; 438 if ConsumeKey then 439 Key := 0; 440end; 441 442procedure TCustomUpDown.AssociateMouseWheel(Sender: TObject; 443 Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; 444 var Handled: Boolean); 445 446begin 447 //debugln('TCustomUpDown.AssociateMouseWheel A: Handled = ',DbgS(Handled)); 448 if (WheelDelta > 0) then 449 begin 450 AdjustPos(True); 451 Handled := True; 452 end 453 else if (WheelDelta < 0) then 454 begin 455 AdjustPos(False); 456 Handled := True; 457 end; 458 //debugln('TCustomUpDown.AssociateMouseWheel End: Handled = ',DbgS(Handled)); 459end; 460 461procedure TCustomUpDown.OnAssociateChangeBounds(Sender: TObject); 462begin 463 UpdateAlignButtonPos; 464end; 465 466procedure TCustomUpDown.OnAssociateChangeEnabled(Sender: TObject); 467begin 468 if Assigned(FAssociate) then 469 SetEnabled(FAssociate.Enabled); 470end; 471 472procedure TCustomUpDown.OnAssociateChangeVisible(Sender: TObject); 473begin 474 if Assigned(FAssociate) then 475 SetVisible(FAssociate.Visible); 476end; 477 478function TCustomUpDown.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; 479begin 480 Result := inherited DoMouseWheelDown(Shift, MousePos); 481 if not Result and not FUseWS then 482 TCustomSpeedButton(FMinBtn).Click; 483end; 484 485function TCustomUpDown.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; 486begin 487 Result := inherited DoMouseWheelUp(Shift, MousePos); 488 if not Result and not FUseWS then 489 TCustomSpeedButton(FMaxBtn).Click; 490end; 491 492function TCustomUpDown.DoMouseWheelLeft(Shift: TShiftState; MousePos: TPoint): Boolean; 493begin 494 Result := inherited DoMouseWheelLeft(Shift, MousePos); 495 if not Result then 496 if (Orientation=udHorizontal) and not FUseWS then 497 TCustomSpeedButton(FMinBtn).Click; 498end; 499 500function TCustomUpDown.DoMouseWheelRight(Shift: TShiftState; MousePos: TPoint): Boolean; 501begin 502 Result := inherited DoMouseWheelRight(Shift, MousePos); 503 if not Result then 504 if (Orientation=udHorizontal) and not FUseWS then 505 TCustomSpeedButton(FMaxBtn).Click; 506end; 507 508procedure TCustomUpDown.DoSetBounds(ALeft, ATop, AWidth, AHeight: integer); 509begin 510 inherited; 511 UpdateOrientation; 512end; 513 514procedure TCustomUpDown.SetEnabled(Value: Boolean); 515begin 516 if not FUseWS then 517 begin 518 FMinBtn.Enabled := Value; 519 FMaxBtn.Enabled := Value; 520 end; 521 inherited SetEnabled(Value); 522end; 523 524class function TCustomUpDown.GetControlClassDefaultSize: TSize; 525begin 526 Result.CX := 17; 527 Result.CY := 31; 528end; 529 530procedure TCustomUpDown.CalculatePreferredSize(var PreferredWidth, 531 PreferredHeight: integer; WithThemeSpace: Boolean); 532begin 533 case Orientation of 534 udHorizontal: 535 begin 536 PreferredWidth:=31; 537 PreferredHeight:=17; 538 end; 539 udVertical: 540 begin 541 PreferredWidth:=17; 542 PreferredHeight:=31; 543 end; 544 end; 545end; 546 547procedure TCustomUpDown.Notification(AComponent: TComponent; 548 Operation: TOperation); 549begin 550 inherited Notification(AComponent, Operation); 551 if (Operation = opRemove) and (AComponent = FAssociate) then 552 SetAssociate(nil); 553end; 554 555function TCustomUpDown.GetPosition: SmallInt; 556var 557 av,I : Integer; 558 str : string; 559 InvalidNumber : Boolean; 560begin 561 If Associate <> nil then begin 562 str := Trim(Associate.Caption); 563 str := StringReplace(str, DefaultFormatSettings.ThousandSeparator, '', [rfReplaceAll]); 564 if not TryStrToInt(str, AV) then 565 begin 566 Result := FPosition; 567 Exit; 568 end; 569 //this will also correct for AV > High(SmallInt) or AV < Low(SMallInt) 570 If AV > FMax then 571 AV := FMax; 572 If AV < FMin then 573 AV := FMin; 574 Position := AV; 575 end; 576 Result := FPosition; 577end; 578 579function TCustomUpDown.GetFlat: Boolean; 580begin 581 if FUseWS then 582 Result := false 583 else if FMinBtn<>nil then 584 Result := (FMinBtn as TSpeedButton).Flat 585 else 586 Result := False; 587end; 588 589procedure TCustomUpDown.SetMin(Value: SmallInt); 590begin 591 if Value <> FMin then 592 begin 593 FMin := Value; 594 If FPosition < FMin then 595 Position := FMin; 596 if FUseWS then 597 TWSCustomUpDownClass(WidgetSetClass).SetMinPosition(Self, FMin); 598 end; 599end; 600 601procedure TCustomUpDown.SetMinRepeatInterval(AValue: Byte); 602begin 603 if FMinRepeatInterval = AValue then Exit; 604 FMinRepeatInterval := AValue; 605 if FMinRepeatInterval < 25 then FMinRepeatInterval := 25; 606end; 607 608procedure TCustomUpDown.SetMax(Value: SmallInt); 609begin 610 if Value <> FMax then 611 begin 612 FMax := Value; 613 If FPosition > FMax then 614 Position := FMax; 615 if FUseWS then 616 TWSCustomUpDownClass(WidgetSetClass).SetMaxPosition(Self, FMax); 617 end; 618end; 619 620procedure TCustomUpDown.SetIncrement(Value: Integer); 621begin 622 if Value <> FIncrement then begin 623 FIncrement := Value; 624 if FUseWS then 625 TWSCustomUpDownClass(WidgetSetClass).SetIncrement(Self, FIncrement); 626 end; 627end; 628 629procedure TCustomUpDown.SetPosition(Value: SmallInt); 630begin 631 if FPosition = Value then exit; 632 FPosition := Value; 633 if FUseWS then 634 TWSCustomUpDownClass(WidgetSetClass).SetPosition(Self, FPosition); 635 UpdateUpDownPositionText; 636end; 637 638procedure TCustomUpDown.SetOrientation(Value: TUDOrientation); 639begin 640 if FOrientation = Value then exit; 641 FOrientation := Value; 642 if FUseWS then 643 TWSCustomUpDownClass(WidgetSetClass).SetOrientation(Self, FOrientation); 644 645 UpdateOrientation; 646end; 647 648procedure TCustomUpDown.SetAlignButton(Value: TUDAlignButton); 649begin 650 if FAlignButton = Value then exit; 651 FAlignButton := Value; 652 UpdateAlignButtonPos; 653end; 654 655procedure TCustomUpDown.SetArrowKeys(Value: Boolean); 656begin 657 if Value <> FArrowKeys then begin 658 FArrowKeys := Value; 659 if FUseWS then 660 TWSCustomUpDownClass(WidgetSetClass).SetUseArrowKeys(Self, Value); 661 end; 662end; 663 664procedure TCustomUpDown.SetThousands(Value: Boolean); 665begin 666 if Value <> FThousands then 667 FThousands := Value; 668end; 669 670procedure TCustomUpDown.SetFlat(Value: Boolean); 671begin 672 if FUseWS then Exit; // todo: not supported by WS yet 673 if Flat = Value then Exit; 674 675 (FMinBtn as TSpeedButton).Flat := Value; 676 (FMaxBtn as TSpeedButton).Flat := Value; 677end; 678 679procedure TCustomUpDown.SetWrap(Value: Boolean); 680begin 681 if Value <> FWrap then 682 FWrap := Value; 683 if FUseWS then 684 TWSCustomUpDownClass(WidgetSetClass).SetWrap(Self, FWrap); 685end; 686 687// included by comctrls.pp 688 689