1{%MainUnit ../comctrls.pp} 2 3{ TToolButton 4 5 ***************************************************************************** 6 This file is part of 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} 13 14{ TToolButtonActionLink } 15 16procedure TToolButtonActionLink.AssignClient(AClient: TObject); 17begin 18 inherited AssignClient(AClient); 19 FClient := AClient as TToolButton; 20end; 21 22function TToolButtonActionLink.IsCheckedLinked: Boolean; 23begin 24 Result := inherited IsCheckedLinked and 25 (TToolButton(FClient).Down = (Action as TCustomAction).Checked); 26end; 27 28function TToolButtonActionLink.IsImageIndexLinked: Boolean; 29begin 30 Result := inherited IsImageIndexLinked and 31 (TToolButton(FClient).ImageIndex = (Action as TCustomAction).ImageIndex); 32end; 33 34procedure TToolButtonActionLink.SetChecked(Value: Boolean); 35begin 36 if IsCheckedLinked then 37 TToolButton(FClient).Down := Value; 38end; 39 40procedure TToolButtonActionLink.SetImageIndex(Value: Integer); 41begin 42 if IsImageIndexLinked then 43 TToolButton(FClient).ImageIndex := Value; 44end; 45 46{ TToolButton } 47 48constructor TToolButton.Create(TheOwner: TComponent); 49begin 50 inherited Create(TheOwner); 51 FImageIndex := -1; 52 FStyle := tbsButton; 53 FShowCaption := true; 54 ControlStyle := [csCaptureMouse, csSetCaption, csDesignNoSmoothResize]; 55 with GetControlClassDefaultSize do 56 SetInitialBounds(0, 0, CX, CY); 57 AccessibleRole := larToolBarButton; 58end; 59 60procedure TToolButton.MouseDown(Button: TMouseButton; Shift: TShiftState; 61 X, Y: Integer); 62 63 procedure SendButtonUpMsg; 64 var 65 msg: TLMMouse; 66 pt: TPoint; 67 begin 68 FillChar({%H-}msg, SizeOf(msg), 0); 69 msg.Msg:=LM_LBUTTONUP; 70 pt := ScreenToClient(Mouse.CursorPos); 71 msg.XPos:=pt.X; 72 msg.YPos:=pt.Y; 73 WndProc(TLMessage(msg)); 74 end; 75var 76 NewFlags: TToolButtonFlags; 77 APointInArrow: Boolean; 78begin 79 //debugln(['TToolButton.MouseDown ',DbgSName(Self)]); 80 SetMouseInControl(True); 81 NewFlags := FToolButtonFlags - [tbfPressed, tbfArrowPressed]; 82 if (Button = mbLeft) then 83 begin 84 APointInArrow := PointInArrow(X, Y); 85 //use some threshold to decide if the DropdownMenu should be opened again. 86 // When no DropdownMenu is assigned, FLastDropDownTick is always 0 87 // therefore the condition is always met. 88 if Enabled and not( 89 (GetTickCount64 < FLastDropDownTick + 100) 90 and (APointInArrow or (Style<>tbsDropDown))) then 91 begin 92 if APointInArrow then 93 Include(NewFlags, tbfArrowPressed) 94 else 95 Include(NewFlags, tbfPressed); 96 end; 97 if NewFlags <> FToolButtonFlags then 98 begin 99 FToolButtonFlags := NewFlags; 100 Invalidate; 101 end; 102 end; 103 104 FLastDown := Down; 105 106 inherited MouseDown(Button, Shift, X, Y); 107 108 FLastDropDownTick := 0; 109 if (Button = mbLeft) and Enabled and 110 (Style in [tbsButton, tbsDropDown, tbsButtonDrop]) then 111 begin 112 if ((Style in [tbsButton, tbsButtonDrop]) and (tbfPressed in NewFlags) or 113 (Style = tbsDropDown) and (tbfArrowPressed in NewFlags)) and 114 CheckMenuDropdown then 115 begin 116 FLastDropDownTick := GetTickCount64; 117 118 //because we show the DropdownMenu in MouseDown, we have to send 119 // LM_LBUTTONUP manually to make it work in all widgetsets! 120 // Some widgetsets work without it (e.g. win32) but some don't (e.g. carbon). 121 SendButtonUpMsg; 122 end else 123 begin 124 if (Style = tbsDropDown) and 125 (NewFlags * [tbfArrowPressed, tbfPressed] = [tbfPressed]) 126 then 127 Down := True; 128 end; 129 end; 130end; 131 132procedure TToolButton.MouseUp(Button: TMouseButton; Shift: TShiftState; 133 X, Y: Integer); 134var 135 ButtonPressed, ArrowPressed: Boolean; 136 Pt: TPoint; 137 NewFlags: TToolButtonFlags; 138begin 139 //DebugLn(['TToolButton.MouseUp ',Name,':',ClassName,' ',dbgs(ord(Button)),' ',X,',',Y]); 140 FLastDown := False; 141 NewFlags := FToolButtonFlags; 142 ButtonPressed := (Button = mbLeft) and (tbfPressed in NewFlags); 143 ArrowPressed := (Button = mbLeft) and (tbfArrowPressed in NewFlags); 144 if ButtonPressed then 145 Exclude(NewFlags, tbfPressed); 146 if ArrowPressed then 147 Exclude(NewFlags, tbfArrowPressed); 148 if (tbfMouseInArrow in NewFlags) and PointInArrow(X, Y) then 149 Exclude(NewFlags, tbfMouseInArrow); 150 151 if NewFlags <> FToolButtonFlags then 152 begin 153 FToolButtonFlags := NewFlags; 154 Invalidate; 155 end; 156 157 inherited MouseUp(Button, Shift, X, Y); 158 159 if (Button = mbLeft) then 160 begin 161 if FMouseInControl then 162 begin 163 Pt := Point(X, Y); 164 if not PtInRect(Rect(0,0,Width,Height), Pt) then 165 SetMouseInControl(false); 166 end; 167 if (Style in [tbsButton, tbsDropDown, tbsButtonDrop]) then 168 Down := False; 169 //button is pressed, but DropdownMenu was not shown 170 if FMouseInControl and (FLastDropDownTick = 0) then 171 begin 172 if ButtonPressed then 173 begin 174 if (Style = tbsCheck) then 175 Down := not Down; 176 Click; 177 end else 178 if ArrowPressed then 179 ArrowClick; 180 //DON'T USE the tool button (Self) after the click call because it could 181 //have been destroyed in the OnClick event handler (e.g. Lazarus IDE does it)! 182 end; 183 end; 184end; 185 186procedure TToolButton.Notification(AComponent: TComponent; Operation: TOperation); 187begin 188 inherited Notification(AComponent, Operation); 189 if Operation = opRemove then 190 begin 191 if AComponent = DropdownMenu then 192 DropdownMenu := nil 193 else 194 if AComponent = MenuItem then 195 MenuItem := nil; 196 end; 197end; 198 199procedure TToolButton.Paint; 200 201 procedure DrawDropDownArrow(OwnerDetails: TThemedElementDetails; const DropDownButtonRect: TRect); 202 var 203 Details: TThemedElementDetails; 204 ArrowState: TThemedToolBar; 205 begin 206 if Style = tbsButtonDrop then 207 begin 208 if Enabled then 209 ArrowState := ttbSplitButtonDropDownNormal 210 else 211 ArrowState := ttbSplitButtonDropDownDisabled; 212 end else 213 begin 214 ArrowState := TThemedToolBar(ord(ttbSplitButtonDropDownNormal) + OwnerDetails.State - 1); 215 if (tbfArrowPressed in FToolButtonFlags) and FMouseInControl and Enabled then 216 ArrowState := ttbSplitButtonDropDownPressed 217 else 218 if (FToolButtonFlags*[tbfMouseInArrow,tbfPressed] = [tbfPressed]) and not FLastDown then 219 ArrowState := ttbSplitButtonDropDownHot; 220 end; 221 Details := ThemeServices.GetElementDetails(ArrowState); 222 if (FToolBar <> nil) and (not FToolBar.Flat) 223 and (Style <> tbsButtonDrop) and (Details.State in [1, 4]) 224 then 225 Details.State := 2; 226 ThemeServices.DrawElement(Canvas.Handle, Details, DropDownButtonRect); 227 end; 228 229 procedure DrawDivider(Details: TThemedElementDetails; ARect: TRect); 230 begin 231 // theme services have no strict rule to draw divider in the center, 232 // so we should calculate rectangle here 233 // on windows 7 divider can't be less than 4 pixels 234 if FToolBar.IsVertical then 235 begin 236 if (ARect.Bottom - ARect.Top) > 5 then 237 begin 238 ARect.Top := (ARect.Top + ARect.Bottom) div 2 - 3; 239 ARect.Bottom := ARect.Top + 5; 240 end; 241 end 242 else 243 begin 244 if (ARect.Right - ARect.Left) > 5 then 245 begin 246 ARect.Left := (ARect.Left + ARect.Right) div 2 - 3; 247 ARect.Right := ARect.Left + 5; 248 end; 249 end; 250 ThemeServices.DrawElement(Canvas.GetUpdatedHandle([csBrushValid, csPenValid]), 251 Details, ARect); 252 end; 253 254 procedure DrawSeparator(Details: TThemedElementDetails; ARect: TRect); 255 begin 256 // separator is just an empty space between buttons, so we should not draw anything, 257 // but vcl draws line when toolbar is flat, because there is no way to detect 258 // space between flat buttons. Better if we draw something too. One of suggestions 259 // was to draw 2 lines instead of one divider - this way separator and divider will differ 260 if FToolBar.Flat then // draw it only for flat Toolbar 261 begin 262 if FToolBar.IsVertical then 263 begin 264 if (ARect.Bottom - ARect.Top) >= 10 then 265 begin 266 ARect.Top := (ARect.Top + ARect.Bottom) div 2 - 5; 267 ARect.Bottom := ARect.Top + 5; 268 DrawDivider(Details, ARect); 269 OffsetRect(ARect, 0, 5); 270 DrawDivider(Details, ARect); 271 end 272 else 273 DrawDivider(Details, ARect); 274 end 275 else 276 begin 277 if (ARect.Right - ARect.Left) >= 10 then 278 begin 279 ARect.Left := (ARect.Left + ARect.Right) div 2 - 5; 280 ARect.Right := ARect.Left + 5; 281 DrawDivider(Details, ARect); 282 OffsetRect(ARect, 5, 0); 283 DrawDivider(Details, ARect); 284 end 285 else 286 DrawDivider(Details, ARect); 287 end; 288 end; 289 end; 290 291var 292 PaintRect: TRect; 293 ButtonRect: TRect; 294 MainBtnRect: TRect; 295 DropDownButtonRect: TRect; 296 TextSize: TSize; 297 TextPos: TPoint; 298 IconSize: TSize; 299 IconPos: TPoint; 300 ImgList: TCustomImageList; 301 ImgIndex: integer; 302 Details, TempDetails: TThemedElementDetails; 303 ImgEffect: TGraphicsDrawEffect; 304begin 305 if (FToolBar<>nil) and (ClientWidth>0) and (ClientHeight>0) then 306 begin 307 PaintRect := ClientRect; // the whole paint area 308 309 // calculate button area(s) 310 MainBtnRect := PaintRect; 311 ButtonRect := PaintRect; 312 Details := GetButtonDrawDetail; 313 314 // OnDrawItem 315 if Assigned(FToolBar.OnPaintButton) then 316 begin 317 if (Style in [tbsButton, tbsDropDown, tbsButtonDrop, tbsCheck]) then 318 begin 319 TempDetails := Details; 320 if ((FToolBar <> nil) and not FToolBar.Flat) and (TempDetails.State in [1, 4]) then 321 TempDetails.State := 2; 322 end; 323 324 FToolBar.OnPaintButton(Self, TempDetails.State); 325 exit; 326 end; 327 328 if Style in [tbsDropDown, tbsButtonDrop] then 329 begin 330 DropDownButtonRect := ButtonRect; 331 if Style = tbsDropDown then 332 DropDownButtonRect.Left := DropDownButtonRect.Right-FToolBar.DropDownWidth 333 else 334 begin 335 DropDownButtonRect.Left := DropDownButtonRect.Right-FToolBar.ButtonDropWidth; 336 DropDownButtonRect.Right := DropDownButtonRect.Left + FToolBar.DropDownWidth; 337 end; 338 MainBtnRect.Right := DropDownButtonRect.Left; 339 if Style = tbsDropDown then 340 ButtonRect := MainBtnRect 341 else 342 Inc(MainBtnRect.Right, cDefButtonDropDecArrowWidth); // tbsButtonDrop ignore extra space between button and arrow 343 end 344 else 345 DropDownButtonRect := Rect(0,0,0,0); 346 347 // calculate text size 348 TextSize.cx:=0; 349 TextSize.cy:=0; 350 if (Style in [tbsButton, tbsDropDown, tbsButtonDrop, tbsCheck]) and (FToolBar.ShowCaptions) and 351 ((FToolbar.List and ShowCaption) or not FToolBar.List) and //Allow hide caption only in list mode 352 (Caption <> '') then 353 TextSize := GetTextSize; 354 355 // calculate icon size 356 IconSize := Size(0,0); 357 GetCurrentIcon(ImgList, ImgIndex, ImgEffect); 358 if (ImgList<>nil) then 359 begin 360 IconSize := ImgList.SizeForPPI[FToolBar.ImagesWidth, Font.PixelsPerInch]; 361 if IconSize.cy <= 0 then 362 IconSize.cx := 0; 363 end; 364 365 // calculate text and icon position 366 TextPos:=Point(0,0); 367 IconPos:=Point(0,0); 368 if TextSize.cx > 0 then 369 begin 370 if IconSize.cx > 0 then 371 begin 372 if FToolBar.List then 373 begin 374 // icon left of text 375 IconPos.X:=(MainBtnRect.Left+MainBtnRect.Right-IconSize.cx-TextSize.cx-2) div 2; 376 IconPos.Y:=(MainBtnRect.Top+MainBtnRect.Bottom-IconSize.cy) div 2; 377 TextPos.X:=IconPos.X+IconSize.cx+2; 378 TextPos.Y:=(MainBtnRect.Top+MainBtnRect.Bottom-TextSize.cy) div 2; 379 end else 380 begin 381 // icon above text 382 IconPos.X:=(MainBtnRect.Left+MainBtnRect.Right-IconSize.cx) div 2; 383 IconPos.Y:=(MainBtnRect.Top+MainBtnRect.Bottom-IconSize.cy-TextSize.cy-2) div 2; 384 TextPos.X:=(MainBtnRect.Left+MainBtnRect.Right-TextSize.cx) div 2; 385 TextPos.Y:=IconPos.Y+IconSize.cy+2; 386 end; 387 end else 388 begin 389 // only text 390 TextPos.X:=(MainBtnRect.Left+MainBtnRect.Right-TextSize.cx) div 2; 391 TextPos.Y:=(MainBtnRect.Top+MainBtnRect.Bottom-TextSize.cy) div 2; 392 end; 393 end else 394 if IconSize.cx>0 then 395 begin 396 // only icon 397 IconPos.X:=(MainBtnRect.Left+MainBtnRect.Right-IconSize.cx) div 2; 398 IconPos.Y:=(MainBtnRect.Top+MainBtnRect.Bottom-IconSize.cy) div 2; 399 end; 400 401 // draw button 402 if (Style in [tbsButton, tbsDropDown, tbsButtonDrop, tbsCheck]) then 403 begin 404 // non-Flat toolbars come from old windows where you was able to set how 405 // to draw it by adjusting toolbar window options 406 // with current windows toolbars should be drawn using Theme 407 // so let's treat flat toolbars as starndard toolbars and draw them using ThemeManager 408 // and to draw a non-Flat toolbars we need to somehow mimic always raised state 409 // of their buttons - a good way is to draw them using Hot style also for 410 // normal and disables states 411 TempDetails := Details; 412 if ((FToolBar <> nil) and not FToolBar.Flat) and (TempDetails.State in [1, 4]) then 413 TempDetails.State := 2; 414 415 ThemeServices.DrawElement(Canvas.GetUpdatedHandle([csBrushValid, csPenValid]), 416 TempDetails, ButtonRect); 417 ButtonRect := ThemeServices.ContentRect(Canvas.Handle, TempDetails, ButtonRect); 418 end 419 else 420 if Style = tbsDivider then 421 begin 422 DrawDivider(Details, ButtonRect); 423 ButtonRect := Rect(0, 0, 0, 0); // nothing can be drawn on divider 424 end 425 else 426 if Style = tbsSeparator then 427 begin 428 if ThemeServices.ThemesEnabled then begin 429 Details:=ThemeServices.GetElementDetails(ttbSeparatorNormal); 430 ThemeServices.DrawElement(Canvas.Handle,Details,ClientRect) 431 end else 432 DrawSeparator(Details, ButtonRect); 433 ButtonRect := Rect(0, 0, 0, 0); // nothing can be drawn on separator 434 end; 435 436 // draw dropdown button 437 if Style in [tbsDropDown, tbsButtonDrop] then 438 DrawDropDownArrow(Details, DropDownButtonRect); 439 440 // draw icon 441 if (ImgList<>nil) then 442 ImgList.ResolutionForPPI[FToolBar.ImagesWidth, Font.PixelsPerInch, GetCanvasScaleFactor] 443 .Draw(Canvas, IconPos.X, IconPos.Y, ImgIndex, ImgEffect); 444 445 // draw text 446 if (TextSize.cx > 0) then 447 begin 448 MainBtnRect.Left := TextPos.X; 449 MainBtnRect.Top := TextPos.Y; 450 // if State is disabled then change to PushButtonDisabled since 451 // ToolButtonDisabled text looks not disabled though windows native toolbutton 452 // text drawn with disabled look. For other widgetsets there is no difference which 453 // disabled detail to use 454 TempDetails := Details; 455 if TempDetails.State = 4 then 456 TempDetails := ThemeServices.GetElementDetails(tbPushButtonDisabled); 457 ThemeServices.DrawText(Canvas, TempDetails, Caption, MainBtnRect, 458 DT_LEFT or DT_TOP, 0); 459 end; 460 461 // draw separator (at runtime: just space, at designtime: a rectangle) 462 if (Style = tbsSeparator) and (csDesigning in ComponentState) then 463 begin 464 Canvas.Brush.Color := clBackground; 465 Canvas.Pen.Color := clBlack; 466 dec(PaintRect.Right); 467 dec(PaintRect.Bottom); 468 Canvas.FrameRect(PaintRect); 469 end; 470 end; 471 472 inherited Paint; 473end; 474 475function TToolButton.PointInArrow(const X, Y: Integer): Boolean; 476begin 477 Result := (Style = tbsDropDown) and (FToolBar <> nil) 478 and (Y >= 0) and (Y <= ClientHeight) 479 and (X > ClientWidth - FToolBar.DropDownWidth) and (X <= ClientWidth); 480end; 481 482procedure TToolButton.Loaded; 483begin 484 inherited Loaded; 485 CopyPropertiesFromMenuItem(FMenuItem); 486end; 487 488procedure TToolButton.SetAutoSize(Value: Boolean); 489begin 490 if Value = AutoSize then exit; 491 inherited SetAutoSize(Value); 492 RequestAlign; 493end; 494 495procedure TToolButton.RealSetText(const AValue: TCaption); 496begin 497 if ([csLoading,csDestroying]*ComponentState=[]) then 498 begin 499 InvalidatePreferredSize; 500 GetAccessibleObject.AccessibleName := AValue; 501 inherited RealSetText(AValue); 502 AdjustSize; 503 end 504 else 505 inherited RealSetText(AValue); 506end; 507 508procedure TToolButton.SetToolBar(NewToolBar: TToolBar); 509begin 510 if FToolBar = NewToolBar then exit; 511 Parent := NewToolBar; 512end; 513 514procedure TToolButton.ActionChange(Sender: TObject; CheckDefaults: Boolean); 515var 516 NewAction: TCustomAction; 517begin 518 inherited ActionChange(Sender, CheckDefaults); 519 if Sender is TCustomAction then 520 begin 521 NewAction := TCustomAction(Sender); 522 if (not CheckDefaults) or (not Down) then 523 Down := NewAction.Checked; 524 if (not CheckDefaults) or (ImageIndex<0) then 525 ImageIndex := NewAction.ImageIndex; 526 end; 527end; 528 529procedure TToolButton.ArrowClick; 530begin 531 if Assigned(FOnArrowClick) then 532 FOnArrowClick(Self); 533end; 534 535function TToolButton.GetActionLinkClass: TControlActionLinkClass; 536begin 537 Result := TToolButtonActionLink; 538end; 539 540procedure TToolButton.CopyPropertiesFromMenuItem(const Value: TMenuItem); 541begin 542 if not Assigned(Value) then Exit; 543 BeginUpdate; 544 Action := Value.Action; 545 Caption := Value.Caption; 546 Down := Value.Checked; 547 Enabled := Value.Enabled; 548 Hint := Value.Hint; 549 ImageIndex := Value.ImageIndex; 550 Visible := Value.Visible; 551 EndUpdate; 552end; 553 554procedure TToolButton.CMHitTest(var Message: TCMHitTest); 555begin 556 if (not (Style in [tbsDivider, tbsSeparator])) or (DragKind = dkDock) then 557 Message.Result := 1 558 else 559 Message.Result := 0; 560end; 561 562class procedure TToolButton.WSRegisterClass; 563begin 564 inherited WSRegisterClass; 565 RegisterCustomToolButton; 566end; 567 568procedure TToolButton.MouseEnter; 569begin 570 // DebugLn('TToolButton.MouseEnter ',Name); 571 inherited MouseEnter; 572 SetMouseInControl(true); 573end; 574 575procedure TToolButton.MouseLeave; 576begin 577 // DebugLn('TToolButton.MouseLeave ',Name); 578 inherited MouseLeave; 579 580 if not(tbfDropDownMenuShown in FToolButtonFlags) then 581 begin 582 if (not MouseCapture) 583 and ([tbfPressed, tbfArrowPressed, tbfMouseInArrow] * FToolButtonFlags <> []) then 584 begin 585 Exclude(FToolButtonFlags, tbfPressed); 586 Exclude(FToolButtonFlags, tbfArrowPressed); 587 Exclude(FToolButtonFlags, tbfMouseInArrow); 588 end; 589 SetMouseInControl(false); 590 end; 591end; 592 593procedure TToolButton.MouseMove(Shift: TShiftState; X, Y: Integer); 594var 595 NewFlags: TToolButtonFlags; 596begin 597 inherited MouseMove(Shift, X, Y); 598 599 if (not MouseCapture) and (Style = tbsDropDown) and (FToolBar <> nil) then 600 begin 601 NewFlags := FToolButtonFlags; 602 if PointInArrow(X, Y) then 603 Include(NewFlags, tbfMouseInArrow) 604 else 605 Exclude(NewFlags, tbfMouseInArrow); 606 607 if NewFlags <> FToolButtonFlags then 608 begin 609 FToolButtonFlags := NewFlags; 610 Invalidate; 611 end; 612 end; 613end; 614 615procedure TToolButton.SetDown(Value: Boolean); 616var 617 StartIndex, EndIndex: integer; 618 i: Integer; 619 CurButton: TToolButton; 620begin 621 if Value = FDown then exit; 622 if (csLoading in ComponentState) then 623 begin 624 FDown := Value; 625 Exit; 626 end; 627 628 //DebugLn('TToolButton.SetDown ',Style=tbsCheck,',',FDown,',',GroupAllUpAllowed); 629 if (Style = tbsCheck) and FDown and (not GroupAllUpAllowed) then 630 Exit; 631 632 FDown := Value; 633 634 if (Style = tbsCheck) and FDown and Grouped then 635 begin 636 // uncheck all other in the group 637 GetGroupBounds(StartIndex, EndIndex); 638 if StartIndex >= 0 then 639 begin 640 for i := StartIndex to EndIndex do 641 begin 642 CurButton := FToolBar.Buttons[i]; 643 if (CurButton <> Self) and (CurButton.FDown) then 644 begin 645 CurButton.FDown := False; 646 CurButton.Invalidate; 647 end; 648 end; 649 end; 650 end; 651 652 Invalidate; 653 if Assigned(FToolBar) then 654 FToolBar.ToolButtonDown(Self, FDown); 655end; 656 657procedure TToolButton.SetDropdownMenu(Value: TPopupMenu); 658begin 659 if Value = FDropdownMenu then exit; 660 FDropdownMenu := Value; 661 if Assigned(Value) then 662 Value.FreeNotification(Self); 663end; 664 665procedure TToolButton.SetGrouped(Value: Boolean); 666var 667 StartIndex, EndIndex: integer; 668 CheckedIndex: Integer; 669 i: Integer; 670 CurButton: TToolButton; 671begin 672 if FGrouped = Value then exit; 673 FGrouped := Value; 674 if csLoading in ComponentState then exit; 675 676 // make sure, that only one button in a group is checked 677 while FGrouped and (Style = tbsCheck) and Assigned(FToolBar) do 678 begin 679 GetGroupBounds(StartIndex, EndIndex); 680 if StartIndex >= 0 then 681 begin 682 CheckedIndex := -1; 683 i := StartIndex; 684 while i <= EndIndex do 685 begin 686 CurButton := FToolBar.Buttons[i]; 687 if CurButton.Down then 688 begin 689 if CheckedIndex < 0 then 690 CheckedIndex := i 691 else 692 begin 693 CurButton.Down := False; 694 // the last operation can change everything -> restart 695 break; 696 end; 697 end; 698 inc(i); 699 end; 700 if i > EndIndex then break; 701 end; 702 end; 703end; 704 705procedure TToolButton.SetImageIndex(Value: TImageIndex); 706begin 707 if FImageIndex = Value then exit; 708 FImageIndex := Value; 709 if IsControlVisible and Assigned(FToolBar) then 710 Invalidate; 711end; 712 713procedure TToolButton.SetMarked(Value: Boolean); 714begin 715 if FMarked = Value then exit; 716 FMarked := Value; 717 if FToolBar <> nil then 718 Invalidate; 719end; 720 721procedure TToolButton.SetIndeterminate(Value: Boolean); 722begin 723 if FIndeterminate = Value then exit; 724 if Value then SetDown(False); 725 FIndeterminate := Value; 726 if FToolBar <> nil then 727 Invalidate; 728end; 729 730procedure TToolButton.SetMenuItem(Value: TMenuItem); 731begin 732 if Value = FMenuItem then Exit; 733 // copy values from menuitem 734 // is menuitem is still loading, skip this 735 if Assigned(Value) and not (csLoading in Value.ComponentState) then 736 CopyPropertiesFromMenuItem(Value); 737 FMenuItem := Value; 738 if FMenuItem <> nil then 739 FMenuItem.FreeNotification(Self); 740end; 741 742procedure TToolButton.SetShowCaption(const AValue: boolean); 743begin 744 if FShowCaption=AValue then exit; 745 FShowCaption:=AValue; 746 if IsControlVisible then 747 begin 748 InvalidatePreferredSize; 749 UpdateVisibleToolbar; 750 end; 751end; 752 753procedure TToolButton.SetStyle(Value: TToolButtonStyle); 754begin 755 if FStyle = Value then exit; 756 FStyle := Value; 757 case Value of 758 tbsSeparator: begin 759 Width := cDefSeparatorWidth; 760 Height := cDefSeparatorWidth; 761 end; 762 tbsDivider: begin 763 Width := cDefDividerWidth; 764 Height := cDefDividerWidth; 765 end; 766 end; 767 InvalidatePreferredSize; 768 if IsControlVisible then 769 UpdateVisibleToolbar; 770end; 771 772procedure TToolButton.SetWrap(Value: Boolean); 773begin 774 if FWrap = Value then exit; 775 FWrap := Value; 776 if Assigned(FToolBar) then 777 RefreshControl; 778end; 779 780procedure TToolButton.TextChanged; 781begin 782 inherited TextChanged; 783 if FToolbar = nil then Exit; 784 if FToolbar.ShowCaptions then 785 Invalidate; 786end; 787 788procedure TToolButton.SetMouseInControl(NewMouseInControl: Boolean); 789begin 790 //DebugLn('TToolButton.SetMouseInControl A ',Name,' Old=',FMouseInControl,' New=',NewMouseInControl); 791 if FMouseInControl = NewMouseInControl then exit; 792 FMouseInControl := NewMouseInControl; 793 //DebugLn('TToolButton.SetMouseInControl B ',Name,' Now=',FMouseInControl,' Down=',Down); 794 Invalidate; 795end; 796 797procedure TToolButton.CMEnabledChanged(var Message: TLMEssage); 798begin 799 inherited; 800 invalidate; 801end; 802 803procedure TToolButton.CMVisibleChanged(var Message: TLMessage); 804begin 805 if FToolBar <> nil then 806 RefreshControl; 807end; 808 809procedure TToolButton.BeginUpdate; 810begin 811 Inc(FUpdateCount); 812end; 813 814procedure TToolButton.EndUpdate; 815begin 816 Dec(FUpdateCount); 817end; 818 819{------------------------------------------------------------------------------ 820 procedure TToolButton.GetGroupBounds(var StartIndex, EndIndex: integer); 821 822 Return the index of the first and the last ToolButton in the group. 823 If no ToolBar then negative values are returned. 824 If not in a group then StartIndex=EndIndex. 825------------------------------------------------------------------------------} 826procedure TToolButton.GetGroupBounds(var StartIndex, EndIndex: integer); 827var 828 CurButton: TToolButton; 829begin 830 StartIndex := Index; 831 EndIndex := StartIndex; 832 if (Style <> tbsCheck) or (not Grouped) then exit; 833 while (StartIndex>0) do 834 begin 835 CurButton:=FToolBar.Buttons[StartIndex-1]; 836 if (CurButton<>nil) and CurButton.Grouped and (CurButton.Style in [tbsCheck, tbsSeparator, tbsDivider]) then 837 dec(StartIndex) 838 else 839 break; 840 end; 841 while (EndIndex < FToolBar.FButtons.Count-1) do 842 begin 843 CurButton := FToolBar.Buttons[EndIndex+1]; 844 if Assigned(CurButton) and CurButton.Grouped and (CurButton.Style in [tbsCheck, tbsSeparator, tbsDivider]) then 845 inc(EndIndex) 846 else 847 break; 848 end; 849end; 850 851function TToolButton.GetIndex: Integer; 852begin 853 if Assigned(FToolBar) then 854 Result := FToolBar.FButtons.IndexOf(Self) 855 else 856 Result := -1; 857end; 858 859function TToolButton.GetTextSize: TSize; 860var 861 S: String; 862begin 863 S := Caption; 864 DeleteAmpersands(S); 865 Result := Canvas.TextExtent(S) 866end; 867 868procedure TToolButton.GetPreferredSize( 869 var PreferredWidth, PreferredHeight: integer; Raw: boolean; 870 WithThemeSpace: boolean); 871var 872 RealButtonWidth, RealButtonHeight: Integer; 873begin 874 inherited GetPreferredSize(PreferredWidth, PreferredHeight, Raw, WithThemeSpace); 875 876 if FToolbar = nil then Exit; 877 RealButtonWidth := FToolbar.ButtonWidth; 878 RealButtonHeight := FToolbar.ButtonHeight; 879 if RealButtonHeight <= 0 then Exit; 880 // buttonheight overrules in hor toolbar 881 if FToolBar.IsVertical then 882 PreferredWidth := RealButtonWidth 883 else 884 PreferredHeight := RealButtonHeight; 885end; 886 887function TToolButton.IsWidthStored: Boolean; 888begin 889 Result := Style in [tbsSeparator, tbsDivider]; 890 if FToolBar<>nil then 891 Result := Result and FToolBar.IsVertical; 892end; 893 894procedure TToolButton.RefreshControl; 895begin 896 UpdateControl; 897end; 898 899procedure TToolButton.UpdateControl; 900begin 901 UpdateVisibleToolbar; 902end; 903 904function TToolButton.CheckMenuDropdown: Boolean; 905begin 906 Result := (not (csDesigning in ComponentState)) and 907 ((Assigned(DropdownMenu) and (DropdownMenu.AutoPopup)) or Assigned(MenuItem)) and Assigned(FToolBar); 908 if Result then 909 begin 910 Include(FToolButtonFlags, tbfDropDownMenuShown); 911 try 912 Result := FToolBar.CheckMenuDropdown(Self); 913 finally 914 Exclude(FToolButtonFlags, tbfDropDownMenuShown); 915 end; 916 end; 917end; 918 919procedure TToolButton.Click; 920begin 921 inherited Click; 922end; 923 924procedure TToolButton.GetCurrentIcon(var ImageList: TCustomImageList; 925 var TheIndex: integer; var TheEffect: TGraphicsDrawEffect); 926var 927 UseAutoEffects: Integer; 928begin 929 ImageList := nil; 930 TheIndex := -1; 931 TheEffect := gdeNormal; 932 UseAutoEffects := ThemeServices.GetOption(toUseGlyphEffects); 933 if (ImageIndex < 0) or (FToolBar = nil) then Exit; 934 935 if Style in [tbsButton, tbsDropDown, tbsButtonDrop, tbsCheck] then 936 begin 937 TheIndex := ImageIndex; 938 ImageList := FToolBar.Images; 939 if (FToolButtonFlags*[tbfPressed,tbfArrowPressed] = [tbfPressed]) then 940 begin 941 // if button pressed then use PressedImages // Maybe To-Do ? 942 {if (FToolBar.PressedImages <> nil) and (ImageIndex < FToolBar.PressedImages.Count) then 943 ImageList := FToolBar.DisabledImages 944 else} if UseAutoEffects > 0 then 945 TheEffect := gdeShadowed; 946 end else 947 if Enabled and FMouseInControl then 948 begin 949 // if mouse over button then use HotImages 950 if (FToolBar.HotImages <> nil) and (ImageIndex < FToolBar.HotImages.Count) then 951 ImageList := FToolBar.HotImages 952 else if UseAutoEffects > 0 then 953 TheEffect := gdeHighlighted; 954 end else 955 if not Enabled then 956 begin 957 // if button disabled then use DisabledImages 958 if (FToolBar.DisabledImages <> nil) and (ImageIndex < FToolBar.DisabledImages.Count) then 959 ImageList := FToolBar.DisabledImages 960 else 961 TheEffect := gdeDisabled; 962 end; 963 end; 964end; 965 966function TToolButton.IsCheckedStored: Boolean; 967begin 968 Result := (ActionLink = nil) or not TToolButtonActionLink(ActionLink).IsCheckedLinked; 969end; 970 971function TToolButton.IsHeightStored: Boolean; 972begin 973 Result := Style in [tbsSeparator, tbsDivider]; 974 if FToolBar<>nil then 975 Result := Result and not FToolBar.IsVertical; 976end; 977 978function TToolButton.IsImageIndexStored: Boolean; 979begin 980 Result := (ActionLink = nil) or not TToolButtonActionLink(ActionLink).IsImageIndexLinked; 981end; 982 983procedure TToolButton.AssignTo(Dest: TPersistent); 984begin 985 inherited AssignTo(Dest); 986 if Dest is TCustomAction then 987 begin 988 TCustomAction(Dest).Checked := Down; 989 TCustomAction(Dest).ImageIndex := ImageIndex; 990 end; 991end; 992 993function TToolButton.GetButtonDrawDetail: TThemedElementDetails; 994var 995 ToolDetail: TThemedToolBar; 996begin 997 if Style = tbsDropDown then 998 ToolDetail := ttbSplitButtonNormal 999 else 1000 if Style in [tbsDivider, tbsSeparator] then 1001 if FToolBar.IsVertical then 1002 ToolDetail := ttbSeparatorVertNormal 1003 else 1004 ToolDetail := ttbSeparatorNormal 1005 else 1006 ToolDetail := ttbButtonNormal; 1007 1008 if not Enabled then 1009 inc(ToolDetail, 3) // ttbButtonDisabled 1010 else 1011 begin 1012 if Down then 1013 begin // checked states 1014 if (tbfPressed in FToolButtonFlags) and FMouseInControl then 1015 inc(ToolDetail, 2) // ttbButtonPressed 1016 else if FMouseInControl then 1017 inc(ToolDetail, 5) // ttbButtonCheckedHot 1018 else 1019 inc(ToolDetail, 4);// ttbButtonChecked 1020 end 1021 else 1022 begin 1023 if (tbfPressed in FToolButtonFlags) and FMouseInControl then 1024 inc(ToolDetail, 2) // ttbButtonPressed 1025 else if FMouseInControl then 1026 inc(ToolDetail, 1);// ttbButtonHot 1027 end; 1028 end; 1029 Result := ThemeServices.GetElementDetails(ToolDetail); 1030end; 1031 1032procedure TToolButton.SetParent(AParent: TWinControl); 1033var 1034 i: Integer; 1035 NewWidth: Integer; 1036 NewHeight: Integer; 1037begin 1038 CheckNewParent(AParent); 1039 if AParent=Parent then exit; 1040 1041 // remove from old button list 1042 if Assigned(FToolBar) then 1043 FToolBar.RemoveButton(Self); 1044 FToolBar := nil; 1045 if AParent is TToolBar then 1046 begin 1047 if not TToolBar(AParent).IsVertical then begin 1048 if Style in [tbsButton,tbsDropDown,tbsButtonDrop,tbsCheck] then 1049 NewWidth := TToolBar(AParent).ButtonWidth 1050 else 1051 NewWidth := Width; 1052 NewHeight := TToolBar(AParent).ButtonHeight; 1053 end else begin 1054 if Style in [tbsButton,tbsDropDown,tbsButtonDrop,tbsCheck] then 1055 NewHeight := TToolBar(AParent).ButtonHeight 1056 else 1057 NewHeight := Height; 1058 NewWidth := TToolBar(AParent).ButtonWidth; 1059 end; 1060 SetBoundsKeepBase(Left, Top, NewWidth, NewHeight); 1061 end; 1062 1063 // inherited 1064 inherited SetParent(AParent); 1065 1066 // add to new button list 1067 if Parent is TToolBar then 1068 begin 1069 FToolBar := TToolBar(Parent); 1070 i := Index; 1071 if i < 0 then 1072 FToolBar.AddButton(Self); 1073 UpdateVisibleToolbar; 1074 end; 1075 //DebugLn(['TToolButton.SetParent A ',Name,' NewIndex=',Index]); 1076end; 1077 1078procedure TToolButton.UpdateVisibleToolbar; 1079begin 1080 //DebugLn('TToolButton.UpdateVisibleToolbar ',Parent is TToolBar); 1081 if Parent is TToolBar then 1082 TToolBar(Parent).UpdateVisibleBar; 1083end; 1084 1085function TToolButton.GroupAllUpAllowed: boolean; 1086var 1087 StartIndex, EndIndex: integer; 1088 i: Integer; 1089 CurButton: TToolButton; 1090begin 1091 Result := True; 1092 if (Style = tbsCheck) and Grouped then 1093 begin 1094 GetGroupBounds(StartIndex, EndIndex); 1095 if (StartIndex >= 0) then 1096 begin 1097 // allow all up, if one button has AllowAllUp 1098 Result := False; 1099 for i := StartIndex to EndIndex do 1100 begin 1101 CurButton := FToolBar.Buttons[i]; 1102 if CurButton.AllowAllUp then 1103 begin 1104 Result := True; 1105 break; 1106 end; 1107 end; 1108 end; 1109 end; 1110end; 1111 1112function TToolButton.DialogChar(var Message: TLMKey): boolean; 1113begin 1114 if IsAccel(Message.CharCode, Caption) and FToolBar.ShowCaptions then 1115 begin 1116 Click; 1117 Result := true; 1118 end else 1119 Result := inherited; 1120end; 1121 1122procedure TToolButton.CalculatePreferredSize(var PreferredWidth, 1123 PreferredHeight: integer; WithThemeSpace: Boolean); 1124var 1125 IconSize: TSize; 1126 TextSize: TSize; 1127 TextPos: TPoint; 1128 IconPos: TPoint; 1129 ImgList: TCustomImageList; 1130 ImgIndex: integer; 1131 ImgEffect: TGraphicsDrawEffect; 1132begin 1133 if Assigned(FToolBar) then 1134 begin 1135 PreferredWidth := 0; 1136 PreferredHeight := 0; 1137 1138 // calculate text size 1139 TextSize.cx := 0; 1140 TextSize.cy := 0; 1141 if (Style in [tbsButton, tbsDropDown, tbsButtonDrop, tbsCheck]) and (FToolBar.ShowCaptions) and 1142 //Allow hide caption only in list mode 1143 ((FToolBar.List and ShowCaption) or not FToolBar.List) then 1144 begin 1145 if (Caption<>'') then 1146 begin 1147 if FToolBar.HandleAllocated then 1148 TextSize := GetTextSize; 1149 end; 1150 // add space around text 1151 inc(TextSize.cx, 4); 1152 inc(TextSize.cy, 4); 1153 end; 1154 1155 // calculate icon size 1156 IconSize := Size(0, 0); 1157 if (Style in [tbsButton, tbsDropDown, tbsButtonDrop, tbsCheck]) then 1158 begin 1159 GetCurrentIcon(ImgList, ImgIndex, ImgEffect); 1160 if Assigned(ImgList) then 1161 begin 1162 IconSize := ImgList.SizeForPPI[FToolBar.ImagesWidth, FToolBar.Font.PixelsPerInch]; 1163 if IconSize.cy <= 0 then IconSize.cx := 0; 1164 end; 1165 end; 1166 // calculate text and icon position 1167 TextPos := Point(0, 0); 1168 IconPos := Point(0, 0); 1169 if TextSize.cx > 0 then 1170 begin 1171 if IconSize.cx > 0 then 1172 begin 1173 if FToolBar.List then 1174 begin 1175 // icon left of text 1176 TextPos.X := IconPos.X + IconSize.cx + 2; 1177 end 1178 else 1179 begin 1180 // icon above text 1181 TextPos.Y := IconPos.Y + IconSize.cy + 2; 1182 end; 1183 end 1184 else 1185 begin 1186 // only text 1187 end; 1188 end 1189 else 1190 if IconSize.cx > 0 then 1191 begin 1192 // only icon 1193 end; 1194 1195 PreferredWidth := Max(IconPos.X + IconSize.cx, TextPos.X + TextSize.cx); 1196 PreferredHeight := Max(IconPos.Y + IconSize.cy, TextPos.Y + TextSize.cy); 1197 //DebugLn(['TToolButton.CalculatePreferredSize Preferred=',PreferredWidth,',',PreferredHeight,' Icon=',IconPos.X,'+',IconSize.Width,' Text=',TextPos.X,'+',TextSize.cx]); 1198 //DebugLn(['TToolButton.CalculatePreferredSize Preferred=',PreferredWidth,',',PreferredHeight,' Icon=',IconPos.Y,'+',IconSize.Height,' Text=',TextPos.Y,'+',TextSize.cy]); 1199 1200 // add button frame 1201 if (Style in [tbsButton, tbsDropDown, tbsButtonDrop, tbsCheck]) then 1202 begin 1203 inc(PreferredWidth, 4); 1204 inc(PreferredHeight, 4); 1205 PreferredWidth := Max(PreferredWidth, FToolBar.ButtonWidth); 1206 PreferredHeight := Max(PreferredHeight, FToolBar.ButtonHeight); 1207 case Style of 1208 tbsDropDown: inc(PreferredWidth, FToolBar.DropDownWidth); 1209 tbsButtonDrop: inc(PreferredWidth, FToolBar.ButtonDropWidth-cDefButtonDropDecArrowWidth); 1210 end; 1211 end 1212 else 1213 if Style = tbsDivider then 1214 if FToolBar.IsVertical then 1215 PreferredHeight := cDefDividerWidth 1216 else 1217 PreferredWidth := cDefDividerWidth 1218 else 1219 if Style = tbsSeparator then 1220 if FToolBar.IsVertical then 1221 PreferredHeight := cDefSeparatorWidth 1222 else 1223 PreferredWidth := cDefSeparatorWidth; 1224 end; 1225 //DebugLn(['TToolButton.CalculatePreferredSize ',DbgSName(Self),' ',PreferredWidth,',',PreferredHeight,' Caption=',Caption]); 1226end; 1227 1228class function TToolButton.GetControlClassDefaultSize: TSize; 1229begin 1230 Result.CX := 23; 1231 Result.CY := 22; 1232end; 1233 1234 1235// included by comctrls.pp 1236 1237