1{%MainUnit ../comctrls.pp} 2 3{****************************************************************************** 4 TCustomHeaderControl 5 ****************************************************************************** 6 7 ***************************************************************************** 8 This file is part of the Lazarus Component Library (LCL) 9 10 See the file COPYING.modifiedLGPL.txt, included in this distribution, 11 for details about the license. 12 ***************************************************************************** 13 14} 15{ TCustomHeaderControl } 16 17const HeaderBorderSize = 2; 18 DragStartDistance = 5; 19 20procedure TCustomHeaderControl.SetImages(const AValue: TCustomImageList); 21begin 22 if FImages = AValue then 23 Exit; 24 if FImages <> nil then 25 FImages.RemoveFreeNotification(Self); 26 FImages := AValue; 27 if FImages <> nil then 28 FImages.FreeNotification(Self); 29end; 30 31procedure TCustomHeaderControl.SetImagesWidth(const aImagesWidth: Integer); 32begin 33 if FImagesWidth = aImagesWidth then Exit; 34 FImagesWidth := aImagesWidth; 35end; 36 37function TCustomHeaderControl.GetSectionFromOriginalIndex(OriginalIndex: Integer): THeaderSection; 38var 39 i: Longint; 40begin 41 Result := nil; 42 for i := 0 to FSections.Count - 1 do 43 if FSections[i].OriginalIndex = OriginalIndex then 44 Exit(FSections[i]); 45end; 46 47procedure TCustomHeaderControl.SetSections(const AValue: THeaderSections); 48begin 49 FSections := AValue; 50end; 51 52procedure TCustomHeaderControl.UpdateSection(Index: Integer); 53begin 54 // repaint item 55 Repaint; 56end; 57 58procedure TCustomHeaderControl.UpdateSections; 59{var 60 i: integer;} 61begin 62{ for i := 0 to Sections.Count - 1 do 63 UpdateSection(i); 64 } 65 Repaint; 66end; 67 68function TCustomHeaderControl.CreateSection: THeaderSection; 69var 70 HeaderSectionClass: THeaderSectionClass; 71begin 72 HeaderSectionClass := THeaderSection; 73 if Assigned(FOnCreateSectionClass) then 74 FOnCreateSectionClass(Self, HeaderSectionClass); 75 Result := HeaderSectionClass.Create(Sections); 76end; 77 78function TCustomHeaderControl.CreateSections: THeaderSections; 79begin 80 Result := THeaderSections.Create(Self); 81end; 82 83 84 85procedure TCustomHeaderControl.Loaded; 86begin 87 inherited Loaded; 88 FSavedCursor := Cursor; 89 //debugln('TCustomHeaderControl.Loaded: Setting FSavedCursor to ',DbgS(FSavedCursor)); 90end; 91 92constructor TCustomHeaderControl.Create(AOwner: TComponent); 93begin 94 inherited Create(AOwner); 95 FSections := CreateSections; 96 ControlStyle := ControlStyle + [csCaptureMouse, csClickEvents, csNoFocus, csOpaque] - 97 [csSetCaption]; 98 with GetControlClassDefaultSize do 99 SetInitialBounds(0, 0, CX, CY); 100end; 101 102destructor TCustomHeaderControl.Destroy; 103begin 104 FSections.Free; 105 inherited Destroy; 106end; 107 108procedure TCustomHeaderControl.Click; 109var 110 Index: Integer; 111begin 112 if FDown and not FDragging then 113 begin 114 inherited Click; 115 Index := GetSectionAt(ScreenToClient(Mouse.CursorPos)); 116 if Index <> -1 then 117 SectionClick(Sections[Index]); 118 end; 119end; 120 121procedure TCustomHeaderControl.DblClick; 122begin 123 inherited DblClick; 124 if FTracking then 125 begin 126 SectionSeparatorDblClick(Sections[FSelectedSection]); 127 end; 128end; 129 130function TCustomHeaderControl.GetSectionAt(P: TPoint): Integer; 131var 132 i: integer; 133begin 134 Result := -1; 135 for i := 0 to Sections.Count - 1 do 136 if Sections[i].Visible and (Sections[i].Left <= P.X) and (Sections[i].Right >= P.X) then 137 begin 138 Result := i; 139 break; 140 end; 141end; 142 143procedure TCustomHeaderControl.Notification(AComponent: TComponent; 144 Operation: TOperation); 145begin 146 inherited Notification(AComponent, Operation); 147 if (Operation = opRemove) and (AComponent = FImages) then 148 Images := nil; 149end; 150 151procedure TCustomHeaderControl.SectionClick(Section: THeaderSection); 152begin 153 if Assigned(FOnSectionClick) then 154 OnSectionClick(Self, Section); 155end; 156 157procedure TCustomHeaderControl.SectionResize(Section: THeaderSection); 158begin 159 if Assigned(FOnSectionResize) then 160 FOnSectionResize(Self, Section); 161end; 162 163procedure TCustomHeaderControl.SectionTrack(Section: THeaderSection; 164 State: TSectionTrackState); 165begin 166 if Assigned(FOnSectionTrack) then 167 FOnSectionTrack(Self, Section, Section.FWidth, State); 168end; 169 170procedure TCustomHeaderControl.SectionSeparatorDblClick(Section: THeaderSection); 171begin 172 if Assigned(FOnSectionSeparatorDblClick) then 173 FOnSectionSeparatorDblClick(Self, Section); 174end; 175 176procedure TCustomHeaderControl.SectionEndDrag(); 177begin 178 if Assigned(FOnSectionEndDrag) then 179 FOnSectionEndDrag(self); 180end; 181 182function TCustomHeaderControl.SectionDrag(FromSection, 183 ToSection: THeaderSection): Boolean; 184begin 185 Result:=DragReorder; 186 if Result and Assigned(FOnSectionDrag) then 187 FOnSectionDrag(self,FromSection,ToSection,Result); 188end; 189 190procedure TCustomHeaderControl.MouseEnter; 191begin 192 inherited MouseEnter; 193 if not (csDesigning in ComponentState) then 194 begin 195 FSavedCursor := Cursor; 196 //debugln('TCustomHeaderControl.MouseEnter: setting FSavedCursor to ',dbgS(FSavedCursor)); 197 FMouseInControl := True; 198 UpdateState; 199 end; 200end; 201 202procedure TCustomHeaderControl.MouseLeave; 203begin 204 inherited MouseLeave; 205 if not (csDesigning in ComponentState) then 206 begin 207 FMouseInControl := False; 208 FDown := False; 209 if not FTracking then 210 Cursor := FSavedCursor; 211 UpdateState; 212 end; 213end; 214 215procedure TCustomHeaderControl.MouseDown(Button: TMouseButton; 216 Shift: TShiftState; X, Y: Integer); 217begin 218 inherited MouseDown(Button, Shift, X, Y); 219 if not (csDesigning in ComponentState) then 220 begin 221 FDown := True; 222 FDownPoint := Point(X, Y); 223 if Button = mbLeft then 224 if (X > HeaderBorderSize ) and 225 (GetSectionAt(Point(X - HeaderBorderSize, Y))<>GetSectionAt(Point(X + HeaderBorderSize, Y))) then 226 begin 227 FTracking:=true; 228 FSelectedSection:=GetSectionAt(Point(X - HeaderBorderSize, Y)); 229 if FSelectedSection = -1 then 230 FTracking:=false 231 else 232 Cursor:=crSizeE; 233 if FTracking then 234 begin 235 FDown := False; 236 SectionTrack(Sections[FSelectedSection], tsTrackBegin); 237 end; 238 end else 239 FSelectedSection:=GetSectionAt(Point(X, Y)); 240 UpdateState; 241 end; 242end; 243 244procedure TCustomHeaderControl.MouseMove(Shift: TShiftState; X, Y: Integer); 245var CurrentSectionIndex: Integer; 246begin 247 inherited MouseMove(Shift, X, Y); 248 if not (csDesigning in ComponentState) then 249 begin 250 if FTracking and (ssLeft in shift) then 251 begin 252 if x>=FSections[FSelectedSection].Left then 253 begin 254 FSections[FSelectedSection].Width := X - FSections[FSelectedSection].Left; 255 SectionTrack(Sections[FSelectedSection], tsTrackMove); 256 end; 257 end 258 else if FDragging and (ssLeft in shift) then 259 begin 260 CurrentSectionIndex:=GetSectionAt(Point(x,y)); 261 if CurrentSectionIndex>-1 then 262 begin 263 if (Sections[CurrentSectionIndex].GetLeft + Sections[CurrentSectionIndex].Width div 2 < X) then 264 FEndDragSectionIndex:=CurrentSectionIndex+1 265 else 266 FEndDragSectionIndex:=CurrentSectionIndex; 267 if FEndDragSectionIndex < Sections.Count - 1 then 268 FDragging:=SectionDrag(Sections[FSelectedSection],Sections[FEndDragSectionIndex]) 269 else 270 FDragging:=SectionDrag(Sections[FSelectedSection],Sections[Sections.Count - 1]); 271 RePaint; 272 end; 273 end 274 else if FDown then 275 begin 276 if DragReorder and (abs(X-FDownPoint.X) >= DragStartDistance) then 277 begin 278 FDragging:=true; 279 FEndDragSectionIndex:=FSelectedSection; 280 end else 281 if GetSectionAt(Point(X, Y)) <> GetSectionAt(FDownPoint) then 282 FDown := False; 283 end; 284 if shift = [] then 285 if (X > HeaderBorderSize) and 286 (GetSectionAt(Point(X - HeaderBorderSize, Y))<>GetSectionAt(Point(X + HeaderBorderSize, Y))) then 287 Cursor:=crSizeE 288 else 289 Cursor:=FSavedCursor; 290 UpdateState; 291 end; 292end; 293 294procedure TCustomHeaderControl.MouseUp(Button: TMouseButton; 295 Shift: TShiftState; X, Y: Integer); 296begin 297 inherited MouseUp(Button, Shift, X, Y); 298 if FTracking then 299 begin 300 SectionTrack(Sections[FSelectedSection],tsTrackEnd); 301 SectionResize(Sections[FSelectedSection]); 302 end; 303 if FDragging then begin 304 if FSelectedSection<FEndDragSectionIndex then 305 Sections[FSelectedSection].Index:=FEndDragSectionIndex - 1 306 else if FSelectedSection>FEndDragSectionIndex then 307 Sections[FSelectedSection].Index:=FEndDragSectionIndex; 308 SectionEndDrag(); 309 end; 310 FDown := False; 311 FTracking:=false; 312 FDragging:=false; 313 UpdateState; 314end; 315 316procedure TCustomHeaderControl.UpdateState; 317var 318 i, Index: Integer; 319 MaxState: THeaderSectionState; 320 P: TPoint; 321begin 322 MaxState := hsNormal; 323 Index := -1; 324 if Enabled then 325 if FDown then 326 begin 327 MaxState := hsPressed; 328 Index := FSelectedSection; 329 end else if FMouseInControl then 330 begin 331 MaxState := hsHot; 332 P := ScreenToClient(Mouse.CursorPos); 333 Index := GetSectionAt(P); 334 end; 335 336 for i := 0 to Sections.Count - 1 do 337 if (i <> Index) then 338 Sections[i].State := hsNormal 339 else 340 Sections[i].State := MaxState; 341end; 342 343class function TCustomHeaderControl.GetControlClassDefaultSize: TSize; 344begin 345 Result.CX := 170; 346 Result.CY := 30; 347end; 348 349procedure TCustomHeaderControl.Paint; 350var 351 Details: TThemedElementDetails; 352 i: integer; 353begin 354 inherited Paint; 355 FPaintRect := Rect(0, 0, Width, Height); 356 357 for i := 0 to Sections.Count - 1 do 358 PaintSection(i); 359 360 if Sections.Count > 0 then 361 FPaintRect.Left := Sections[Sections.Count - 1].Right; 362 if FPaintRect.Left < FPaintRect.Right then 363 begin 364 Details := ThemeServices.GetElementDetails(thHeaderItemRightNormal); 365 ThemeServices.DrawElement(Canvas.Handle, Details, FPaintRect); 366 end; 367 368 if FDragging then 369 begin 370 Canvas.Pen.Width:=2; 371 Canvas.Pen.Color:=clHotLight; 372 if FEndDragSectionIndex < Sections.Count then 373 Canvas.MoveTo(Sections[FEndDragSectionIndex].Left,0) 374 else 375 Canvas.MoveTo(Sections[Sections.Count - 1].Right,0); 376 Canvas.LineTo(canvas.PenPos.x,ClientHeight); 377 end; 378end; 379 380procedure TCustomHeaderControl.PaintSection(Index: Integer); 381const 382 AlignmentMap: array[TAlignment] of Cardinal = 383 ( 384 DT_LEFT, 385 DT_RIGHT, 386 DT_CENTER 387 ); 388 HeaderStateMap: array[THeaderSectionState] of TThemedHeader = 389 ( 390 thHeaderItemNormal, 391 thHeaderItemHot, 392 thHeaderItemPressed 393 ); 394var 395 ARect, ContentRect: TRect; 396 Details: TThemedElementDetails; 397 Section: THeaderSection; 398 ImagesSize: TSize; 399begin 400 Section := Sections[Index]; 401 if not Section.Visible then Exit; 402 ARect := FPaintRect; 403 ARect.Left := FPaintRect.Left + Section.Left; 404 ARect.Right := FPaintRect.Left + Section.Right; 405 if ARect.Right <= ARect.Left then 406 exit; 407 Details := ThemeServices.GetElementDetails(HeaderStateMap[Section.State]); 408 409 ThemeServices.DrawElement(Canvas.Handle, Details, ARect); 410 ContentRect := ThemeServices.ContentRect(Canvas.Handle, Details, ARect); 411 if CompareMem(@ContentRect, @ARect, SizeOf(ARect)) then 412 InflateRect(ContentRect, -3, -3); 413 414 if (Images <> nil) and (Section.ImageIndex <> -1) then 415 begin 416 inc(ContentRect.Left); 417 ImagesSize := Images.SizeForPPI[ImagesWidth, Font.PixelsPerInch]; 418 ThemeServices.DrawIcon(Canvas, Details, 419 Point(ContentRect.Left, (ContentRect.Top + ContentRect.Bottom - ImagesSize.cy) div 2), 420 Images, Section.ImageIndex); 421 inc(ContentRect.Left, ImagesSize.cx + 2); 422 end; 423 424 if Section.Text <> '' then 425 ThemeServices.DrawText(Canvas, Details, Section.Text, ContentRect, AlignmentMap[Section.Alignment] or DT_VCENTER or DT_SINGLELINE, 0); 426end; 427 428procedure TCustomHeaderControl.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy; 429 const AXProportion, AYProportion: Double); 430var 431 I: integer; 432 Sect: THeaderSection; 433begin 434 inherited; 435 436 if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then 437 begin 438 Sections.BeginUpdate; 439 try 440 for I := 0 to Sections.Count-1 do 441 begin 442 Sect := Sections.Items[I]; 443 Sect.Width := Round(Sect.Width*AXProportion); 444 end; 445 finally 446 Sections.EndUpdate; 447 end; 448 end; 449end; 450 451procedure TCustomHeaderControl.ChangeScale(M, D: Integer); 452var 453 I: integer; 454 Sect: THeaderSection; 455begin 456 inherited; 457 458 Sections.BeginUpdate; 459 try 460 for I := 0 to Sections.Count-1 do 461 begin 462 Sect := Sections.Items[I]; 463 Sect.Width := MulDiv(Sect.Width, M, D); 464 end; 465 finally 466 Sections.EndUpdate; 467 end; 468end; 469 470{ THeaderSections } 471 472function THeaderSections.GetItem(Index: Integer): THeaderSection; 473begin 474 Result := THeaderSection(inherited GetItem(Index)); 475end; 476 477procedure THeaderSections.SetItem(Index: Integer; Value: THeaderSection); 478begin 479 inherited SetItem(Index, Value); 480end; 481 482function THeaderSections.GetOwner: TPersistent; 483begin 484 Result := FHeaderControl; 485end; 486 487procedure THeaderSections.Update(Item: TCollectionItem); 488begin 489 if Item <> nil then 490 FHeaderControl.UpdateSection(Item.Index) 491 else 492 FHeaderControl.UpdateSections; 493end; 494 495constructor THeaderSections.Create(HeaderControl: TCustomHeaderControl); 496begin 497 inherited Create(THeaderSection); 498 FHeaderControl := HeaderControl; 499end; 500 501function THeaderSections.Add: THeaderSection; 502begin 503 Result := AddItem(nil, Count); 504end; 505 506function THeaderSections.AddItem(Item: THeaderSection; Index: Integer): THeaderSection; 507var 508 i: longint; 509begin 510 if Item = nil then 511 Result := FHeaderControl.CreateSection 512 else 513 Result := Item; 514 515 Result.Collection := Self; 516 if Index > Count then 517 Index := Count - 1; 518 Result.Index := Index; 519 //updates OriginalIndex so that it has the value Index would have if there 520 //never was a move 521 for i := 0 to Count - 1 do 522 if Items[i].FOriginalIndex >= Index then 523 Items[i].FOriginalIndex := Items[i].FOriginalIndex + 1; 524 Result.FOriginalIndex := Index; 525end; 526 527function THeaderSections.Insert(Index: Integer): THeaderSection; 528begin 529 Result := AddItem(nil, Index); 530end; 531 532procedure THeaderSections.Delete(Index: Integer); 533var i:longint; 534begin 535 inherited Delete(Index); 536 //updates OriginalIndex so that it has the value Index would have if there 537 //never was a move 538 for i:=0 to Count - 1 do 539 if items[i].FOriginalIndex > Index then 540 items[i].FOriginalIndex := items[i].FOriginalIndex - 1; 541end; 542 543{ THeaderSection } 544 545function THeaderSection.GetWidth: Integer; 546begin 547 if Visible then 548 Result := FWidth 549 else 550 Result := 0; 551end; 552 553function THeaderSection.GetLeft: Integer; 554var 555 i: integer; 556begin 557 Result := 0; 558 for i := 0 to Index - 1 do 559 Inc(Result, THeaderSections(Collection).Items[i].Width); 560end; 561 562function THeaderSection.GetRight: Integer; 563begin 564 Result := GetLeft + Width; 565end; 566 567procedure THeaderSection.SetAlignment(const AValue: TAlignment); 568begin 569 if FAlignment <> AValue then 570 begin 571 FAlignment := AValue; 572 Changed(False); 573 end; 574end; 575 576procedure THeaderSection.SetMaxWidth(AValue: Integer); 577begin 578 if AValue > 10000 then 579 AValue := 10000; 580 if AValue < FMinWidth then 581 AValue := FMinWidth; 582 583 if FMaxWidth <> AValue then 584 begin 585 FMaxWidth := AValue; 586 CheckConstraints; 587 Changed(False); 588 end; 589end; 590 591procedure THeaderSection.SetMinWidth(AValue: Integer); 592begin 593 if AValue < 0 then 594 AValue := 0; 595 if AValue > FMaxWidth then 596 AValue := FMaxWidth; 597 598 if FMinWidth <> AValue then 599 begin 600 FMinWidth := AValue; 601 CheckConstraints; 602 Changed(False); 603 end; 604end; 605 606procedure THeaderSection.SetState(const AValue: THeaderSectionState); 607begin 608 if FState <> AValue then 609 begin 610 FState := AValue; 611 Changed(False); 612 end; 613end; 614 615procedure THeaderSection.SetText(const Value: TCaption); 616begin 617 if FText <> Value then 618 begin 619 FText := Value; 620 Changed(False); 621 end; 622end; 623 624procedure THeaderSection.SetVisible(const AValue: Boolean); 625begin 626 if FVisible <> AValue then 627 begin 628 FVisible := AValue; 629 Changed(False); 630 end; 631end; 632 633procedure THeaderSection.SetWidth(Value: Integer); 634begin 635 if FWidth <> Value then 636 begin 637 FWidth := Value; 638 CheckConstraints; 639 Changed(False); 640 end; 641end; 642 643procedure THeaderSection.SetImageIndex(const Value: TImageIndex); 644begin 645 if FImageIndex <> Value then 646 begin 647 FImageIndex := Value; 648 Changed(False); 649 end; 650end; 651 652procedure THeaderSection.CheckConstraints; 653begin 654 if FWidth < FMinWidth then 655 FWidth := FMinWidth; 656 if FWidth > FMaxWidth then 657 FWidth := FMaxWidth; 658end; 659 660function THeaderSection.GetDisplayName: string; 661begin 662 if Length(Text) = 0 then 663 Result := inherited GetDisplayName 664 else 665 Result := Text; 666end; 667 668constructor THeaderSection.Create(ACollection: TCollection); 669begin 670 inherited Create(ACollection); 671 FWidth := 30; 672 FImageIndex := -1; 673 FText := ''; 674 FAlignment := taLeftJustify; 675 FState := hsNormal; 676 FVisible := True; 677 FMinWidth := 0; 678 FMaxWidth := 10000; 679 FOriginalIndex:=ACollection.Count-1; 680end; 681 682procedure THeaderSection.Assign(Source: TPersistent); 683var 684 SourceSection: THeaderSection absolute Source; 685begin 686 if Source is THeaderSection then 687 begin 688 FImageIndex := SourceSection.ImageIndex; 689 FText := SourceSection.Text; 690 FWidth := SourceSection.Width; 691 Changed(False); 692 end 693 else 694 inherited Assign(Source); 695end; 696