{----------------------------------------------------------------------} { Name : ItemBox } { Purpose : Visual List } { Usage : } { Improvements : } {----------------------------------------------------------------------} // 06 March 2017, TIBItem.Paint's bug resolved on Lazarus release // 12 September 2015: Prototype unit uniItemBox; {$mode objfpc}{$H+} interface uses Classes, SysUtils, Forms, Controls, Contnrs, ExtCtrls, Menus, Graphics; type TIBToolBar = class; TIBItem = class; TIBItemBox = class; TIBToolClicked = (itNone, itCheckBox, itArrowUp, itArrowDown); { TIBToolItem } TIBToolItem = class private FCanvas: TCanvas; FChecked: boolean; FIndex: integer; FToolBar: TIBToolBar; FVisible: boolean; function ClickNormal(const aParent: TScrollBox): TIBToolClicked; virtual; procedure ClickShift(const aParent: TScrollBox); virtual; procedure DoDraw(const aBackgroundColor: TColor; const X: integer); virtual; procedure LineRel(const X, Y: longint); public constructor Create; virtual; procedure DrawToolItem(const aBackgroundColor: TColor; const X: integer); function Width: integer; virtual; end; { TIBToolCheckBox } TIBToolCheckBox = class(TIBToolItem) private function ClickNormal(const aParent: TScrollBox): TIBToolClicked; override; procedure ClickShift(const aParent: TScrollBox); override; procedure DoDraw(const aBackgroundColor: TColor; const X: integer); override; public function Width: integer; override; end; { TIBToolArrowUp } TIBToolArrowUp = class(TIBToolItem) private function ClickNormal(const aParent: TScrollBox): TIBToolClicked; override; procedure DoDraw(const aBackgroundColor: TColor; const X: integer); override; public constructor Create; override; function Width: integer; override; end; { TIBToolArrowDown } TIBToolArrowDown = class(TIBToolItem) private function ClickNormal(const aParent: TScrollBox): TIBToolClicked; override; procedure DoDraw(const aBackgroundColor: TColor; const X: integer); override; public constructor Create; override; function Width: integer; override; end; { TIBToolBar } TIBToolBar = class(TFPObjectList) private FParent: TIBItem; FPosX: integer; public constructor Create(const aParent: TIBItem; const X: integer); overload; procedure Add(const aToolItem: TIBToolItem); procedure DrawToolBar(const aBackgroundColor: TColor; const MouseX: integer); procedure ShowTool(const anIndex: integer; const aStatus: boolean); end; { TIBItem } TIBItem = class(TScrollBox) const FLeft = 70; //xxx todo private FColorHighLighted: TColor; FColorNormal: TColor; FContent: shortstring unimplemented; //xxx test FDoubleClickTesting: boolean; FLastClick: TDateTime; FList: TIBItemBox; // Parent's list FToolBar: TIBToolBar; procedure DrawContent; virtual; function IsMouseHovering: boolean; function IsMouseHoverToolItem(const anIndex, MouseX: integer): boolean; function ItemHeight: integer; virtual; procedure EventAddClick(Sender: TObject); procedure EventClick(Sender: TObject); procedure EventDeleteClick(Sender: TObject); procedure EventDblClick(Sender: TObject); procedure EventEditClick(Sender: TObject); procedure EventMouseEnter(Sender: TObject); procedure EventMouseLeave(Sender: TObject); procedure EventMouseMove(Sender: TObject; Shift: TShiftState; X, Y: integer); public constructor Create; overload; constructor Create(aOwner: TComponent); override; property Data: shortstring read FContent write FContent; procedure Paint; override; end; { TIBItemEmpty } TIBItemEmpty = class(TIBItem) // Used to pass @TIBItemBox to ItemBoxOf public constructor Create(aOwner: TComponent); override; end; { TIBItemBox } TIBItemBoxEventEnum = (ieToolUp, ieToolDown, ieEdit, ieInsert, ieAdd, ieDelete, ieDisconnect); TIBItemBoxEvent = procedure(ItemBox: TIBItemBox; Index1, Index2: integer; Event: TIBItemBoxEventEnum) of object; //xxx todo const TIBItemBox = class(TFPObjectList) private FHovering: integer; FEvent: TIBItemBoxEvent; FMenuCaption: array[1..10] of string; //xxx todo FMenuEvent: array[1..10] of TNotifyEvent; //xxx todo FMenuCount: integer; FScrollBox: TScrollBox; FTimerDelete: TTimer; // Prevent deleting while manipulating item FTimerDisconnect: TTimer; procedure EventAddClick(Sender: TObject); procedure EventMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: integer); procedure EventResize(Sender: TObject); procedure EventTimerDelete(Sender: TObject); procedure EventTimerDisconnect(Sender: TObject); public constructor Create(const aScrollBox: TScrollBox); procedure Add(const anItem: TIBItem); procedure CheckedAdd; procedure CheckedDelete; function CheckedFirst: integer; function CheckedLast: integer; function Disconnect: boolean; function Hovering: integer; function isEmpty: boolean; procedure Migrate(const aSource: TIBItemBox; const anIndexFrom, anIndexTo: integer); function GetScrollBox: TScrollBox; procedure SetEventResponse(const anEvent: TIBItemBoxEvent); procedure SetMenu(const aCaption: string; const anEvent: TNotifyEvent); end; function ItemBoxOf(const anObject: TObject): TIBItemBox; implementation { TIBToolItem } function TIBToolItem.ClickNormal(const aParent: TScrollBox): TIBToolClicked; begin Result := itNone; end; procedure TIBToolItem.ClickShift(const aParent: TScrollBox); begin // Do nothing, to be inherited end; procedure TIBToolItem.DoDraw(const aBackgroundColor: TColor; const X: integer); begin // Do nothing, to be inherited end; procedure TIBToolItem.LineRel(const X, Y: longint); begin with FCanvas do LineTo(PenPos.X + X, PenPos.Y + Y); end; constructor TIBToolItem.Create; begin FCanvas := nil; // Set by TIBToolBar.Add FChecked := False; FIndex := 0; // Set by TIBToolBar.Add FToolBar := nil; // Set by TIBToolBar.Add FVisible := True; end; procedure TIBToolItem.DrawToolItem(const aBackgroundColor: TColor; const X: integer); begin if (FVisible) then DoDraw(aBackgroundColor, X); end; function TIBToolItem.Width: integer; begin Result := 0; end; { TIBToolCheckBox } function TIBToolCheckBox.ClickNormal(const aParent: TScrollBox): TIBToolClicked; var LoopItem: TIBItem; LoopCheckBox: TIBToolCheckBox; i: integer; begin for i := 0 to (aParent.ControlCount - 1) do begin LoopItem := (aParent.Controls[i] as TIBItem); LoopCheckBox := (LoopItem.FToolBar[FIndex] as TIBToolCheckBox); if (LoopCheckBox = Self) then begin // Invert if on hovered item LoopCheckBox.FChecked := not (LoopCheckBox.FChecked); LoopItem.FToolBar.DrawToolBar(LoopItem.FColorNormal, LoopItem.FToolBar.FPosX); end else if (LoopCheckBox.FChecked) then begin // Clear others' status LoopCheckBox.FChecked := False; LoopItem.FToolBar.DrawToolBar(LoopItem.FColorNormal, LoopItem.FToolBar.FPosX); end; end; Result := itCheckBox; end; procedure TIBToolCheckBox.ClickShift(const aParent: TScrollBox); var LoopItem: TIBItem; LoopCheckBox: TIBToolCheckBox; FirstFound, LastFound, i: integer; begin FirstFound := -1; LastFound := -1; for i := (aParent.ControlCount - 1) downto 0 do begin // Find (last or current) LoopItem := (aParent.Controls[i] as TIBItem); LoopCheckBox := (LoopItem.FToolBar[FIndex] as TIBToolCheckBox); if ((LoopCheckBox.FChecked) or (LoopCheckBox = Self)) then LastFound := i; if (LastFound >= 0) then Break; end; for i := 0 to LastFound do begin // Set status from (first or current) to last LoopItem := (aParent.Controls[i] as TIBItem); LoopCheckBox := (LoopItem.FToolBar[FIndex] as TIBToolCheckBox); if ((LoopCheckBox.FChecked) or (LoopCheckBox = Self)) then FirstFound := i; if ((not (LoopCheckBox.FChecked)) and (FirstFound >= 0)) then begin LoopCheckBox.FChecked := True; LoopItem.FToolBar.DrawToolBar(LoopItem.FColorNormal, LoopItem.FToolBar.FPosX); end; end; end; procedure TIBToolCheckBox.DoDraw(const aBackgroundColor: TColor; const X: integer); begin with FCanvas do begin Pen.Width := 1; Rectangle(X + 3, 6, X + 12, 16); if (FChecked) then begin if (Pen.Color = clRed) then // clRed = color of mouse hovering on it Brush.Color := clRed else Brush.Color := clGreen; FillRect(X + 4, 7, X + 11, 15); Brush.Color := aBackgroundColor; end else FillRect(X + 4, 7, X + 11, 15); end; end; function TIBToolCheckBox.Width: integer; begin Result := 16; if (not (FVisible)) then Result := 0; end; { TIBToolArrowUp } function TIBToolArrowUp.ClickNormal(const aParent: TScrollBox): TIBToolClicked; var List: TIBItemBox; ScrollBox: TScrollBox; PosY: integer; FirstFound, i: integer; begin Result := itNone; FirstFound := FToolBar.FParent.FList.CheckedFirst; if (FirstFound <= 0) then Exit; List := ((aParent.Controls[0] as TIBItem).FList as TIBItemBox); // Rearrange for i := FirstFound to FToolBar.FParent.FList.CheckedLast do List.Exchange(i, i - 1); PosY := aParent.VertScrollBar.Position; aParent.Visible := False; ScrollBox := TScrollBox.Create(nil); for i := 0 to (aParent.ControlCount - 1) do // Move to a new parent (List[i] as TIBItem).Parent := ScrollBox; for i := 0 to (ScrollBox.ControlCount - 1) do // Move back to original parent (ScrollBox.Controls[0] as TIBItem).Parent := List.FScrollBox; aParent.VertScrollBar.Position := PosY; aParent.Visible := True; ScrollBox.Free; Result := itArrowUp; end; procedure TIBToolArrowUp.DoDraw(const aBackgroundColor: TColor; const X: integer); begin with FCanvas do begin Pen.Width := 1; MoveTo(X + 7, 6); end; LineRel(-6, 6); LineRel(4, 0); LineRel(0, 4); LineRel(6, 0); LineRel(0, -4); LineRel(4, 0); LineRel(-8, -8); end; constructor TIBToolArrowUp.Create; begin inherited Create; FVisible := False; end; function TIBToolArrowUp.Width: integer; begin Result := 17; if (not (FVisible)) then Result := 0; end; { TIBToolArrowDown } function TIBToolArrowDown.ClickNormal(const aParent: TScrollBox): TIBToolClicked; var List: TIBItemBox; ScrollBox: TScrollBox; PosY: integer; LastFound, i: integer; begin Result := itNone; LastFound := FToolBar.FParent.FList.CheckedLast; if ((LastFound < 0) or (LastFound >= aParent.ControlCount - 1)) then Exit; List := ((aParent.Controls[0] as TIBItem).FList as TIBItemBox); // Rearrange for i := LastFound downto FToolBar.FParent.FList.CheckedFirst do List.Exchange(i, i + 1); PosY := aParent.VertScrollBar.Position; aParent.Visible := False; ScrollBox := TScrollBox.Create(nil); for i := 0 to (aParent.ControlCount - 1) do // Move to a new parent (List[i] as TIBItem).Parent := ScrollBox; for i := 0 to (ScrollBox.ControlCount - 1) do // Move back to original parent (ScrollBox.Controls[0] as TIBItem).Parent := List.FScrollBox; aParent.VertScrollBar.Position := PosY; aParent.Visible := True; ScrollBox.Free; Result := itArrowDown; end; procedure TIBToolArrowDown.DoDraw(const aBackgroundColor: TColor; const X: integer); begin with FCanvas do begin Pen.Width := 1; MoveTo(X + 7, 15); end; LineRel(-6, -6); LineRel(4, 0); LineRel(0, -4); LineRel(6, 0); LineRel(0, 4); LineRel(4, 0); LineRel(-8, 8); end; constructor TIBToolArrowDown.Create; begin inherited Create; FVisible := False; end; function TIBToolArrowDown.Width: integer; begin Result := 17; if (not (FVisible)) then Result := 0; end; { TIBToolBar } constructor TIBToolBar.Create(const aParent: TIBItem; const X: integer); begin inherited Create(True); FParent := aParent; FPosX := X; end; procedure TIBToolBar.Add(const aToolItem: TIBToolItem); begin inherited Add(aToolItem); aToolItem.FCanvas := FParent.Canvas; aToolItem.FIndex := Count - 1; aToolItem.FToolBar := Self; end; procedure TIBToolBar.DrawToolBar(const aBackgroundColor: TColor; const MouseX: integer); var X, i: integer; begin X := FPosX; for i := 0 to (Count - 1) do with (Items[i] as TIBToolItem) do begin if ((MouseX >= X) and (MouseX <= X + Width)) then FCanvas.Pen.Color := clRed // clRed = color of mouse hovering on it else FCanvas.Pen.Color := clGray; // Normal color DrawToolItem(aBackgroundColor, X); X := X + Width; end; end; procedure TIBToolBar.ShowTool(const anIndex: integer; const aStatus: boolean); begin (Items[anIndex] as TIBToolItem).FVisible := aStatus; end; { TIBItem } procedure TIBItem.DrawContent; begin with Canvas do begin Pen.Color := clGray; TextOut(FLeft, 2, FContent); //xxx todo end; end; function TIBItem.IsMouseHovering: boolean; var MouseXY: TPoint; Found: TControl; begin Result := False; MouseXY.X := 0; MouseXY.Y := 0; MouseXY := Parent.ClientToScreen(MouseXY); MouseXY.X := Mouse.CursorPos.X - MouseXY.X; MouseXY.Y := Mouse.CursorPos.Y - MouseXY.Y; Found := Parent.ControlAtPos(MouseXY, [capfAllowDisabled] + [capfAllowWinControls] + [capfOnlyClientAreas] + [capfHasScrollOffset]); if (Found = Self) then Result := True; end; function TIBItem.IsMouseHoverToolItem(const anIndex, MouseX: integer): boolean; var X, i: integer; begin Result := False; if ((anIndex < 0) or (anIndex > FToolBar.Count - 1)) then Exit; X := FToolBar.FPosX; for i := 0 to anIndex do with (FToolBar.Items[i] as TIBToolItem) do begin if ((i = anIndex) and (MouseX >= X) and (MouseX <= X + Width)) then Result := True; X := X + Width; end; end; function TIBItem.ItemHeight: integer; begin Result := 22; end; procedure TIBItem.EventAddClick(Sender: TObject); begin FList.CheckedAdd; end; procedure TIBItem.EventClick(Sender: TObject); var Menu: TPopupMenu; Item: TMenuItem; DurationLimit: TDateTime; ToolClicked: TIBToolClicked; MouseXY: TPoint; Shift: TShiftState; isChecked: boolean; S: string; i: integer; begin FLastClick := Now; MouseXY.X := 0; MouseXY.Y := 0; MouseXY := Parent.ClientToScreen(MouseXY); MouseXY.X := Mouse.CursorPos.X - MouseXY.X; Shift := GetKeyShiftState; for i := 0 to (FToolBar.Count - 1) do with (FToolBar[i] as TIBToolItem) do if (IsMouseHoverToolItem(i, MouseXY.X)) then begin if (ssShift in Shift) then // [Shift] + click ClickShift(Parent as TScrollBox) else begin ToolClicked := ClickNormal(Parent as TScrollBox); // Click if Assigned(FList.FEvent) then case ToolClicked of itArrowUp: FList.FEvent(FList, FList.CheckedFirst, FList.CheckedLast, ieToolUp); itArrowDown: FList.FEvent(FList, FList.CheckedFirst, FList.CheckedLast, ieToolDown); end; end; end; if (MouseXY.X < FLeft) then Exit; if (FList.FTimerDelete.Enabled) then Exit; // Prevent item manipulating while deleting item if (FDoubleClickTesting) then Exit; FDoubleClickTesting := True; DurationLimit := EncodeTime(0, 0, 0, 200); repeat until (Now - FLastClick > DurationLimit); FDoubleClickTesting := False; FLastClick := Now; isChecked := False; S := ''; with FList do begin i := CheckedLast; if (i >= 0) then isChecked := True; if ((i - CheckedFirst) > 0) then S := 's'; end; Menu := TPopupMenu.Create(Self); //xxx todo use with Menu.Parent := Parent; Item := TMenuItem.Create(Menu); Item.Caption := '&Edit This Item' + S; Item.OnClick := @EventEditClick; Menu.Items.Add(Item); if (isChecked) then begin Item := TMenuItem.Create(Menu); Item.Caption := '&Insert Above Checked Item' + S; Item.OnClick := @EventAddClick; Menu.Items.Add(Item); Item := TMenuItem.Create(Menu); Item.Caption := '&Delete Checked Item' + S; Item.OnClick := @EventDeleteClick; Menu.Items.Add(Item); end else begin Item := TMenuItem.Create(Menu); Item.Caption := '&Insert New Item' + S; Item.OnClick := @EventAddClick; Menu.Items.Add(Item); end; Item := TMenuItem.Create(Menu); Item.Caption := '-'; Item.OnClick := nil; Menu.Items.Add(Item); for i := 1 to FToolBar.FParent.FList.FMenuCount do begin Item := TMenuItem.Create(Menu); Item.Caption := FList.FMenuCaption[i]; Item.OnClick := FList.FMenuEvent[i]; Menu.Items.Add(Item); end; with Menu do begin PopUp; Free; end; end; procedure TIBItem.EventDeleteClick(Sender: TObject); begin FList.FTimerDelete.Enabled := True; end; procedure TIBItem.EventDblClick(Sender: TObject); var MouseXY: TPoint; begin MouseXY.X := 0; MouseXY.Y := 0; MouseXY := Parent.ClientToScreen(MouseXY); MouseXY.X := Mouse.CursorPos.X - MouseXY.X; if (MouseXY.X < FLeft) then Exit; EventEditClick(Self); end; procedure TIBItem.EventEditClick(Sender: TObject); var i: integer; begin i := FList.IndexOf(Self); if (assigned(FList.FEvent)) then FList.FEvent(FList, i, i, ieEdit); end; procedure TIBItem.EventMouseEnter(Sender: TObject); begin Paint; end; procedure TIBItem.EventMouseLeave(Sender: TObject); begin FToolBar.FParent.FList.FHovering := -1; Paint; end; procedure TIBItem.EventMouseMove(Sender: TObject; Shift: TShiftState; X, Y: integer); var i: integer; begin for i := 0 to (Parent.ControlCount - 1) do with (Parent.Controls[i] as TIBItem) do FToolBar.DrawToolBar(FColorNormal, 0); FToolBar.DrawToolBar(FColorHighLighted, X); end; constructor TIBItem.Create; begin // Nothing to do, just compiler requirement end; constructor TIBItem.Create(aOwner: TComponent); begin inherited Create(aOwner); Parent := (aOwner as TScrollBox); FColorHighLighted := TColor($AAFFFF); FColorNormal := TColor($FFDDDD); FContent := '~ new ~'; FDoubleClickTesting := False; FLastClick := Now; FList := nil; // Set by TIBItemBox.Add FToolBar := TIBToolBar.Create(Self, 10); with FToolBar do begin Add(TIBToolCheckBox.Create); Add(TIBToolArrowUp.Create); Add(TIBToolArrowDown.Create); end; BorderStyle := bsNone; Constraints.MaxHeight := ItemHeight; Constraints.MaxWidth := Parent.ClientWidth; Constraints.MinHeight := ItemHeight; Constraints.MinWidth := Parent.ClientWidth; TabStop := True; OnClick := @EventClick; OnDblClick := @EventDblClick; OnMouseEnter := @EventMouseEnter; OnMouseLeave := @EventMouseLeave; OnMouseMove := @EventMouseMove; end; procedure TIBItem.Paint; var i: integer; begin with Canvas do if IsMouseHovering then begin Brush.Color := clBlack; FillRect(0, 0, Width, ItemHeight); // FillRect(0, 0, Width, ItemHeight); //xxx bug resolved on new release Brush.Color := FColorHighLighted; FillRect(2, 2, Width - 2, ItemHeight - 2); FToolBar.ShowTool(1, True); FToolBar.ShowTool(2, True); for i := 0 to (FToolBar.FParent.FList.Count - 1) do if (Self = FToolBar.FParent.FList.Items[i]) then begin FList.FHovering := i; Break; end; end else begin Brush.Color := clDefault; FillRect(0, 0, Width, ItemHeight); Brush.Color := FColorNormal; FillRect(1, 1, Width - 1, ItemHeight - 1); FToolBar.ShowTool(1, False); FToolBar.ShowTool(2, False); end; DrawContent; FToolBar.DrawToolBar(FColorNormal, 0); end; { TIBItemEmpty } constructor TIBItemEmpty.Create(aOwner: TComponent); begin inherited Create(aOwner); Visible := False; end; { TIBItemBox } procedure TIBItemBox.EventAddClick(Sender: TObject); begin Add(TIBItem.Create); if (assigned(FEvent)) then FEvent(Self, Count - 1, Count - 1, ieAdd); end; procedure TIBItemBox.EventMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: integer); var Empty: TIBItemEmpty; Menu: TPopupMenu; Item: TMenuItem; i: integer; begin if ((FTimerDelete.Enabled) or (FTimerDisconnect.Enabled)) then Exit; Empty := nil; if (Count = 0) then begin // Using an empty item to pass @TIBItemBox to ItemBoxOf Empty := TIBItemEmpty.Create(FScrollBox); Empty.FList := Self; Menu := TPopupMenu.Create(Empty); end else Menu := TPopupMenu.Create(Items[0] as TIBItem); Menu.Parent := FScrollBox; //xxx todo use with Item := TMenuItem.Create(Menu); Item.Caption := '&Add New Item'; Item.OnClick := @EventAddClick; Menu.Items.Add(Item); Item := TMenuItem.Create(Menu); Item.Caption := '-'; Item.OnClick := nil; Menu.Items.Add(Item); for i := 1 to FMenuCount do begin Item := TMenuItem.Create(Menu); Item.Caption := FMenuCaption[i]; Item.OnClick := FMenuEvent[i]; Menu.Items.Add(Item); end; with Menu do begin PopUp; Free; end; if Assigned(Empty) then begin Remove(Empty); Empty.Free; end; end; procedure TIBItemBox.EventResize(Sender: TObject); var i: integer; begin if ((FTimerDelete.Enabled) or (FTimerDisconnect.Enabled)) then Exit; with FScrollBox do for i := 0 to (ControlCount - 1) do with (Controls[i] as TIBItem).Constraints do begin MaxWidth := Parent.ClientWidth; MinWidth := Parent.ClientWidth; end; end; procedure TIBItemBox.EventTimerDelete(Sender: TObject); begin CheckedDelete; FTimerDelete.Enabled := False; end; procedure TIBItemBox.EventTimerDisconnect(Sender: TObject); begin if (FTimerDelete.Enabled) then Exit; FEvent(nil, -1, -1, ieDisconnect); FTimerDisconnect.Enabled := False; end; constructor TIBItemBox.Create(const aScrollBox: TScrollBox); begin inherited Create(False); FEvent := nil; FHovering := -1; FMenuCount := 0; FScrollBox := aScrollBox; with FScrollBox do begin ChildSizing.Layout := cclLeftToRightThenTopToBottom; OnMouseDown := @EventMouseDown; OnResize := @EventResize; end; FTimerDelete := TTimer.Create(Application); with FTimerDelete do begin Enabled := False; Interval := 20; OnTimer := @EventTimerDelete; end; FTimerDisconnect := TTimer.Create(Application); with FTimerDisconnect do begin Enabled := False; Interval := 500; OnTimer := @EventTimerDisconnect; end; end; procedure TIBItemBox.Add(const anItem: TIBItem); begin inherited Add(anItem); anItem.Create(FScrollBox); anItem.FList := Self; end; procedure TIBItemBox.CheckedAdd; var ScrollBox: TScrollBox; PosY: integer; FirstFound, i: integer; begin FirstFound := CheckedFirst; if (FirstFound < 0) then FirstFound := Hovering; if (FirstFound < 0) then Exit; Add(TIBItem.Create); for i := (FScrollBox.ControlCount - 1) downto (FirstFound + 1) do // Rearrange Exchange(i - 1, i); PosY := FScrollBox.VertScrollBar.Position; FScrollBox.Visible := False; ScrollBox := TScrollBox.Create(nil); for i := 0 to (FScrollBox.ControlCount - 1) do // Move to a new parent (Items[i] as TIBItem).Parent := ScrollBox; for i := 0 to (ScrollBox.ControlCount - 1) do // Move back to original parent (ScrollBox.Controls[0] as TIBItem).Parent := FScrollBox; FScrollBox.VertScrollBar.Position := PosY; FScrollBox.Visible := True; ScrollBox.Free; if (assigned(FEvent)) then FEvent(Self, FirstFound, FirstFound, ieInsert); end; procedure TIBItemBox.CheckedDelete; var LastFound, i: integer; begin LastFound := CheckedLast; if (LastFound < 0) then Exit; for i := LastFound downto CheckedFirst do begin Remove(FScrollBox.Controls[i]); FScrollBox.Controls[i].Free; end; if (assigned(FEvent)) then FEvent(Self, i, LastFound, ieDelete); end; function TIBItemBox.CheckedFirst: integer; var ToolBar: TIBToolBar; LoopItem: TIBItem; LoopCheckBox: TIBToolCheckBox; Index, i: integer; begin Result := -1; if (isEmpty) then Exit; Index := -1; ToolBar := (Items[0] as TIBItem).FToolBar; for i := 0 to (ToolBar.Count - 1) do // Find index of TIBToolCheckBox if (ToolBar[i].ClassNameIs('TIBToolCheckBox')) then Index := i; if (Index < 0) then Exit; for i := 0 to (FScrollBox.ControlCount - 1) do begin // Find first checked LoopItem := (FScrollBox.Controls[i] as TIBItem); LoopCheckBox := (LoopItem.FToolBar[Index] as TIBToolCheckBox); if (LoopCheckBox.FChecked) then begin Result := i; Exit; end; end; end; function TIBItemBox.CheckedLast: integer; var ToolBar: TIBToolBar; LoopItem: TIBItem; LoopCheckBox: TIBToolCheckBox; Index, i: integer; begin Result := -1; if (isEmpty) then Exit; Index := -1; ToolBar := (Items[0] as TIBItem).FToolBar; for i := 0 to (ToolBar.Count - 1) do // Find index of TIBToolCheckBox if (ToolBar[i].ClassNameIs('TIBToolCheckBox')) then Index := i; if (Index < 0) then Exit; for i := (FScrollBox.ControlCount - 1) downto 0 do begin // Find first checked LoopItem := (FScrollBox.Controls[i] as TIBItem); LoopCheckBox := (LoopItem.FToolBar[Index] as TIBToolCheckBox); if (LoopCheckBox.FChecked) then begin Result := i; Exit; end; end; end; function TIBItemBox.Disconnect: boolean; begin Result := False; if ((FTimerDelete.Enabled) or (FTimerDisconnect.Enabled)) then Exit; FTimerDisconnect.Enabled := True; Result := True; end; function TIBItemBox.Hovering: integer; begin if (isEmpty) then FHovering := -1; Result := FHovering; end; function TIBItemBox.isEmpty: boolean; begin Result := False; if (Count <= 0) then Result := True; if (Count = 1) then if (Items[0].ClassNameIs('TIBItemEmpty')) then Result := True; end; procedure TIBItemBox.Migrate(const aSource: TIBItemBox; const anIndexFrom, anIndexTo: integer); var Item: TIBItem; begin Item := (aSource.Items[anIndexFrom] as TIBItem); Item.FList.Extract(Item); Item.FList := Self; inherited Add(Item); (Item.Owner as TScrollBox).RemoveComponent(Item); FScrollBox.InsertComponent(Item); Item.Parent := FScrollBox; end; function TIBItemBox.GetScrollBox: TScrollBox; begin Result := FScrollBox; end; procedure TIBItemBox.SetEventResponse(const anEvent: TIBItemBoxEvent); begin FEvent := anEvent; end; procedure TIBItemBox.SetMenu(const aCaption: string; const anEvent: TNotifyEvent); begin Inc(FMenuCount); FMenuCaption[FMenuCount] := aCaption; FMenuEvent[FMenuCount] := anEvent; end; function ItemBoxOf(const anObject: TObject): TIBItemBox; begin Result := nil; if (anObject.ClassNameIs('TMenuItem')) then Result := (((anObject as TMenuItem).Owner as TPopupMenu).Owner as TIBItem).FList; end; end.