TB2Merge, Version 0.4 (alt)

{
  TB2Merge.pas

  Copyright (C) 2005 Volker Siebert, Germany
  All rights reserved.

DESCRIPTION

  This unit for Delphi 5, 6, 7, and 2005 contains code for merging the items
  of two Toolbar2000 controls (and so TBX, SpTBX and other derivates).

  The intention from writing this code came from the work on porting an older
  application with *many* MDI child forms to TBX, using a TTBXToolBar as the
  main menu bar.

  Use the global "ToolbarMerger" (it's a function but should be used like
  a variable) to merge and unmerge two toolbars and/or menu bars.

  Sample usage for fsMDIChild forms:

  interface part:

    type
      TfrmChild = class(TForm)
        ...
      protected
        procedure WMMDIActivate(var Message: TWMMDIActivate); message WM_MDIACTIVATE;
        ...
      end;

  implementation part:

    procedure TfrmChild.WMMDIActivate(var Message: TWMMDIActivate);
    begin
      inherited;

      if Message.ActiveWnd = Handle then
        ToolbarMerger.Merge(frmMain.tbMainMenu, tbChildMenu, [])
      else
        ToolbarMerger.UnmergeAll(tbChildMenu);
    end;

  Sample usage for all forms:

  events:

    procedure TfrmChild.FormActivate(Sender: TObject);
    begin
      ToolbarMerger.Merge(frmMain.tbMainMenu, tbChildMenu, []);
    end;

    procedure TfrmChild.FormDeactivate(Sender: TObject);
    begin
      ToolbarMerger.UnmergeAll(tbChildMenu);
    end;

    procedure TfrmChild.FormDestroy(Sender: TObject);
    begin
      ToolbarMerger.UnmergeAll(tbChildMenu);
    end;

LICENSE

  The contents of this file are subject to the Mozilla Public License
  Version 1.1 (the "License"); you may not use this file except in
  compliance with the License. You may obtain a copy of the License at
  http://www.mozilla.org/MPL/

  Software distributed under the License is distributed on an "AS IS"
  basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
  License for the specific language governing rights and limitations
  under the License.

CHANGELOG

  2005-07-15: Version 0.4
    - Some further code cleanup.
    - Updated information for fsMDIChild windows on how to use the merger.
    - Added the option "moSeparatorAfterItems".

  2005-06-30: Version 0.3
    - Changed the way how "hiding" works, hidden items are no longer moved
      to the source side but are simply kept in our list without parent. This
      way we can restore them even if the source is destroyed unexpectedly.

  2005-06-27: Version 0.2
    - Added "TBFixImageList" to merge toolbars with different image lists.
    - Changed the way how separator items are grouped, see "FindEndOfGroup".

  2005-06-25: Version 0.1
    - Initial version
}

unit TB2Merge;

interface

uses
  Classes, SysUtils, Menus, Controls, ImgList, TB2Dock, TB2Item;

type
  { TTBUnmergeItem holds a single atomic operation for an "unmerge". This is
    done by simply moving the item back to its old parent and position.
  }
  PTBUnmergeItem = ^TTBUnmergeItem;
  TTBUnmergeItem = record
    Next: PTBUnmergeItem;     // Single linked list
    Item: TTBCustomItem;      // Which item
    Parent: TTBCustomItem;    // Old parent
    ParentIndex: Integer;     // Old parent index
  end;

  { These are the options for the merge process. They tell TBMergeItems
    what to do with a block of items having the same GroupIndex.

    If you neither specify moKeepTarget nor moRecursive, the default action
    is to replace the entire target block by the source block. This mimics
    the behaviour of the VCL when merging two menus.

    With moKeepTarget, we try to find a matching source entry for each target
    item (read below about how a matching entry is identified). If we find
    one, the target item is replaced by this match. If not, the target item
    will be kept in place. After that the remaining unused source items are
    appended at the end of the target block.

    moRecursive works like moKeepTarget, i.e., we try to find a matching
    entry for each target item. The difference comes when we find two
    matching items with submenus. Here the target item is kept (including
    all of its properties) and instead the both submenus' items are merged
    recursively.

    By default the system identifies matching entries by their name, i.e.,
    tbMainMenuBar.miFileSave and tbChildMenuBar.miFileSave match because
    they have the same name. Using moMatchByCaption or moMatchByTag changes
    this behaviour and items are identified by their caption resp. by their
    tag number.

    If you specify moSeparatorAfterItems, separators are grouped with the
    items that *precede* them. The default is to group them with the items
    that follow them.
  }
  TTBMergeOption = (
    moKeepTarget,             // Keep non-matching target entries
    moRecursive,              // Recurse into matching items' submenus
    moMatchByCaption,         // Identify matching items by their caption
    moMatchByTag,             // Identify matching items by their tag
    moSeparatorAfterItems     // Separators shall belong to their preceding items
  );

  TTBMergeOptions = set of TTBMergeOption;

function  TBMergeItems(Target, Source: TTBCustomItem; Options: TTBMergeOptions): PTBUnmergeItem;
procedure TBUnmergeItems(Target, Source: TTBCustomItem; List: PTBUnmergeItem);
procedure TBFreeUnmergeItems(List: PTBUnmergeItem);
procedure TBFixImageList(Items: TTBCustomItem; Images: TCustomImageList);

type
  { TTBMergedItems is just an OOP wrapper for the functions above. Upon
    creation, the two sets of items are merged and they are automatically
    unmerged when the object is deleted.
  }
  TTBMergedItems = class(TObject)
  private
    FTarget: TComponent;
    FSource: TComponent;
    FUnmergeItems: PTBUnmergeItem;
    FOptions: TTBMergeOptions;

  public
    constructor Create(ATarget, ASource: TComponent; Options: TTBMergeOptions);
    destructor Destroy; override;

    procedure Merge;
    procedure Unmerge;
    procedure Dispose;

    property Target: TComponent read FTarget;
    property Source: TComponent read FSource;
    property UnmergeItems: PTBUnmergeItem read FUnmergeItems;
    property Options: TTBMergeOptions read FOptions;
  end;

type
  { Don't use a TTBToolbarMerger component directly, use the one returned
    by the function "ToolbarMerger".
  }
  TTBToolbarMerger = class(TComponent)
  private
    FMergedItems: TList;

    function GetCount: Integer;
    function GetItem(Index: Integer): TTBMergedItems;

  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure Merge(Target, Source: TComponent; Options: TTBMergeOptions);
    procedure Unmerge(Target, Source: TComponent);
    procedure UnmergeAll(Comp: TComponent);
    procedure Delete(Index: Integer);
    function  IsMerged(Target: TComponent): Integer;
    function  IsMergedWith(Source: TComponent): Integer;
    procedure Clear;

    property Count: Integer read GetCount stored false;
    property Items[Index: Integer]: TTBMergedItems read GetItem stored false;
  end;

function ToolbarMerger: TTBToolbarMerger;

implementation

{$B-,R-}

uses
  Windows, Forms;

{######################################################################
 Misc. declarations
 ######################################################################
}

{ TTBItemAccess is just a hack to get access to the protected members of
  TTBCustomItem, especially: "tbisSubmenu in TTBItemAccess(i).ItemStyle".
}
type
  TTBItemAccess = class(TTBCustomItem);

{ Notify the item that it's going to be updated (a lot)
}
procedure BeginUpdateItem(Item: TTBCustomItem);
begin
  if Item <> nil then
  begin
    if Item.ParentComponent <> nil then
      if Item.ParentComponent is TTBCustomDockableWindow then
        TTBCustomDockableWindow(Item.ParentComponent).BeginUpdate;

    Item.ViewBeginUpdate;
  end;
end;

{ Notify the item that all updates are finished
}
procedure EndUpdateItem(Item: TTBCustomItem);
begin
  if Item <> nil then
  begin
    Item.ViewEndUpdate;

    if Item.ParentComponent <> nil then
      if Item.ParentComponent is TTBCustomDockableWindow then
        TTBCustomDockableWindow(Item.ParentComponent).EndUpdate;
  end;
end;

{ Get the root item for the given component
}
function GetComponentItems(Comp: TComponent): TTBCustomItem;
var
  Intf: ITBItems;
begin
  if Comp = nil then
    Result := nil
  else if Comp is TTBCustomItem then
    Result := TTBCustomItem(Comp)
  else if Comp.GetInterface(ITBItems, Intf) then
    Result := Intf.GetItems
  else
    Result := nil;
end;

{######################################################################
 Procedure/function interface (non OOP)
 ######################################################################
}

{ Sets the "Images" Property of *ALL* toolbar items to the one
  specified as parameter. }
procedure TBFixImageList(Items: TTBCustomItem; Images: TCustomImageList);
var
  Index: Integer;
  Item: TTBCustomItem;
begin
  if Images <> nil then
    for Index := Items.Count - 1 downto 0 do
    begin
      Item := Items.Items[Index];
      Item.Images := Images;
      if tbisSubmenu in TTBItemAccess(Item).ItemStyle then
        TBFixImageList(Item, Images);
    end;
end;

{ Free all memory associated with the given list of UnmergeItems.
}
procedure TBFreeUnmergeItems(List: PTBUnmergeItem);
var
  Head: PTBUnmergeItem;
begin
  while List <> nil do
  begin
    Head := List;
    List := Head^.Next;

    if (Head^.Item <> nil) and (Head^.Item.Parent = nil) then
      Head^.Item.Free;

    Dispose(Head);
  end;
end;

{ Unmerge the subitems of target and source, using the given list of
  UnmergeItems. While doing this, the list will be freed. The parameters
  Target and Source are same as for the TBMergeItems call that produced
  the list of PTBUnmergeItems.
}
procedure TBUnmergeItems(Target, Source: TTBCustomItem; List: PTBUnmergeItem);
var
  Op: PTBUnmergeItem;
begin
  if (Target <> nil) and (csDestroying in Target.ComponentState) then
    Target := nil;
  if (Source <> nil) and (csDestroying in Source.ComponentState) then
    Source := nil;

  BeginUpdateItem(Target);
  try
    BeginUpdateItem(Source);
    try
      try
        while List <> nil do
        begin
          Op := List;
          List := Op^.Next;

          if Target = nil then
          begin
            // Target was deleted in the meanwhile, source items are lost
            if Op^.Item.Parent = nil then
              Op^.Item.Free;
          end
          else if Op^.Item.Parent <> nil then
          begin
            // Source that was moved to target
            Op^.Item.Parent.Remove(Op^.Item);

            if Source <> nil then
              Op^.Parent.Insert(Op^.ParentIndex, Op^.Item)
            else
              Op^.Item.Free;
          end
          else
          begin
            // Target was hidden (moved to this queue)
            Op^.Parent.Insert(Op^.ParentIndex, Op^.Item);
          end;

          Dispose(Op);
        end;
      except
        TBFreeUnmergeItems(List);
        raise;
      end;
    finally
      EndUpdateItem(Source);
    end;
  finally
    EndUpdateItem(Target);
  end;
end;

{ Merge the subitems of target and source, using the given options. The return
  value is a list of "unmerge" UnmergeItems that will revert all modifications.
}
function TBMergeItems(Target, Source: TTBCustomItem; Options: TTBMergeOptions): PTBUnmergeItem;
var
  List: PTBUnmergeItem;

  { Find the end of the group of items from "Items" starting at index "Start".
    Upon exit, the parameter "Stop" is set to the index of the first item
    *AFTER* the found group and "Group" to the found "GroupIndex".

    If "Start" points to a valid item in the list, the value of "Group" is
    "Items.Items[Start].GroupIndex" and "Stop" is at least "Start+1".

    If "Start" points beyond the list, "Stop" is set equal to "Start".
  }
  procedure FindEndOfGroup(Items: TTBCustomItem; var Start: Integer; out Stop, Group: Integer);
  begin
    if not (moSeparatorAfterItems in Options) then
    begin
      // First skip over all separator items, i.e., find the "real" start
      Stop := Start;
      while (Stop < Items.Count) and
            (tbisSeparator in TTBItemAccess(Items.Items[Stop]).ItemStyle) do
        inc(Stop);

      if Stop = Items.Count then
        Group := 0
      else
      begin
        // We found the first item with a real group index
        Group := Items.Items[Stop].GroupIndex;
        inc(Stop);

        // Now collect all items having at least this group index
        while (Stop < Items.Count) and (Items.Items[Stop].GroupIndex <= Group) do
          inc(Stop);

        // If we did not reach the end, remove all trailing separator items
        if Stop < Items.Count then
          while (Stop > Start) and
                (tbisSeparator in TTBItemAccess(Items.Items[Stop - 1]).ItemStyle) do
            dec(Stop);
      end;
    end
    else if Start < Items.Count then
    begin
      Group := Items.Items[Start].GroupIndex;
      Stop := Start + 1;
      while (Stop < Items.Count) and (Items.Items[Stop].GroupIndex <= Group) do
        inc(Stop);
    end
    else
    begin
      Group := 0;
      Stop := Start;
    end;
  end;

  { Move one item from OldParent.Items[OldIndex] to its new position at
    NewParent.Items[NewIndex] and store the corresponding "unmerge"
    operation in our List. Returns true upon successful completion.
  }
  function MoveItem(NewParent: TTBCustomItem; NewIndex: Integer;
                    OldParent: TTBCustomItem; OldIndex: Integer): Boolean;
  var
    Op: PTBUnmergeItem;
  begin
    Result := (OldIndex >= 0) and (OldIndex < OldParent.Count);
    if Result then
    begin
      New(Op);
      try
        Op^.Next := List;
        Op^.Item := OldParent.Items[OldIndex];
        Op^.Parent := OldParent;
        Op^.ParentIndex := OldIndex;

        OldParent.Delete(OldIndex);

        if NewParent <> nil then
          try
            NewParent.Insert(NewIndex, Op^.Item);
          except
            OldParent.Insert(OldIndex, Op^.Item);
            raise;
          end;

        List := Op;
      except
        Dispose(Op);
        raise;
      end;
    end;
  end;

  { Move all items between SrcStart and SrcStop (excluding) to the target
    side, adjusting the index parameters accordingly.
  }
  procedure MoveItems(TgtItems: TTBCustomItem; var TgtStart, TgtStop: Integer;
                      SrcItems: TTBCustomItem; var SrcStart, SrcStop: Integer);
  begin
    while (SrcStart < SrcStop) and
          MoveItem(TgtItems, TgtStart, SrcItems, SrcStart) do
    begin
      dec(SrcStop);
      inc(TgtStart);
      inc(TgtStop);
    end;
  end;

  { Hide all items between SrcStart and SrcStop (excluding).
  }
  procedure HideItems(SrcItems: TTBCustomItem; var SrcStart, SrcStop: Integer);
  begin
    while (SrcStart < SrcStop) and
          MoveItem(nil, 0, SrcItems, SrcStart) do
      dec(SrcStop);
  end;

  { Returns the string used to identify a matching item.
  }
  function GetItemIdent(Item: TTBCustomItem): string;
  begin
    if moMatchByCaption in Options then
      Result := StripHotkey(Item.Caption)
    else if moMatchByTag in Options then
      Result := IntToStr(Item.Tag)
    else
      Result := Item.Name;
  end;

  { Look for a matching item for "Find" in the given range of items.
  }
  function FindMatchingItem(Items: TTBCustomItem; Start, Stop: Integer;
                            Find: TTBCustomItem): Integer;
  var
    LookFor: string;
  begin
    LookFor := GetItemIdent(Find);

    Result := -1;

    while (Start < Stop) and (Result < 0) do
    begin
      if CompareText(LookFor, GetItemIdent(Items.Items[Start])) = 0 then
        Result := Start;

      inc(Start);
    end;
  end;

  { Merge the subitems of TgtItems (the target) and SrcItems (the source)
  }
  procedure MergeItems(TgtItems, SrcItems: TTBCustomItem);
  var
    TgtStart, TgtStop, TgtGroup: Integer;
    SrcStart, SrcStop, SrcGroup: Integer;
    Match: Integer;
  begin
    TgtStart := 0;
    FindEndOfGroup(TgtItems, TgtStart, TgtStop, TgtGroup);

    SrcStart := 0;
    FindEndOfGroup(SrcItems, SrcStart, SrcStop, SrcGroup);

    while (TgtStart < TgtStop) and (SrcStart < SrcStop) do
    begin
      if TgtGroup < SrcGroup then
      begin
        // Target block's "GroupIndex" is less than the source block's, the
        // target block of items will be kept (no modification).
        TgtStart := TgtStop;
      end
      else if SrcGroup < TgtGroup then
      begin
        // Source block's "GroupIndex" is less than the target block's, the
        // source block will be inserted completely.
        MoveItems(TgtItems, TgtStart, TgtStop, SrcItems, SrcStart, SrcStop);
      end
      else
      begin
        if moKeepTarget in Options then
        begin
          // Add new entries from source to target and replace them resp.
          // merge the subitems of matching ones.
          while TgtStart < TgtStop do
          begin
            // Find match for the next item on the target side
            Match := FindMatchingItem(SrcItems, SrcStart, SrcStop, TgtItems.Items[TgtStart]);
            if Match < 0 then
            begin
              // No match found
              inc(TgtStart);
            end
            else if (moRecursive in Options) and
                    (tbisSubmenu in TTBItemAccess(SrcItems.Items[SrcStart]).ItemStyle) and
                    (tbisSubmenu in TTBItemAccess(TgtItems.Items[TgtStart]).ItemStyle) then
            begin
              // Recurse into both lists of subitems
              MergeItems(TgtItems.Items[TgtStart], SrcItems.Items[SrcStart]);
              inc(SrcStart);
              inc(TgtStart);
            end
            else
            begin
              // Hide old target item
              MoveItem(nil, 0, TgtItems, TgtStart);
              // Move source to target
              MoveItem(TgtItems, TgtStart, SrcItems, Match);
              dec(SrcStop);
              inc(TgtStart);
            end;
          end;
        end;

        // Replace target with source, i.e. hide target items and move source
        // items to the target side. For moKeepTarget, the target side is
        // already empty (TgtStart = TgtStop) and the remainder of the source
        // side must be copied completely.
        HideItems(TgtItems, TgtStart, TgtStop);
        MoveItems(TgtItems, TgtStart, TgtStop, SrcItems, SrcStart, SrcStop);
      end;

      if TgtStart >= TgtStop then
        // Find next group on target side
        FindEndOfGroup(TgtItems, TgtStart, TgtStop, TgtGroup);

      if SrcStart >= SrcStop then
        // Find next group on source side
        FindEndOfGroup(SrcItems, SrcStart, SrcStop, SrcGroup);
    end;

    // Either the target or the source side reached its end. Just copy
    // the remainding source items over to the end of the target side.
    SrcStop := SrcItems.Count;
    MoveItems(TgtItems, TgtStart, TgtStop, SrcItems, SrcStart, SrcStop);
  end;

begin
  // Do not merge components that are about to be destroyed
  if (Target = nil) or (csDestroying in Target.ComponentState) or
     (Source = nil) or (csDestroying in Source.ComponentState) then
  begin
    Result := nil;
    exit;
  end;

  BeginUpdateItem(Target);
  try
    BeginUpdateItem(Source);
    try
      List := nil;
      try
        if moRecursive in Options then
          include(Options, moKeepTarget);

        MergeItems(Target, Source);
      except
        TBUnmergeItems(Target, Source, List);
        raise;
      end;
    finally
      EndUpdateItem(Source);
    end;
  finally
    EndUpdateItem(Target);
  end;

  Result := List;
end;

{######################################################################
 TTBMergedItems
 ######################################################################
}

constructor TTBMergedItems.Create(ATarget, ASource: TComponent; Options: TTBMergeOptions);
begin
  inherited Create;

  FTarget := ATarget;
  FSource := ASource;
  FOptions := Options;
  FUnmergeItems := nil;

  Merge;
end;

destructor TTBMergedItems.Destroy;
begin
  Unmerge;

  inherited;
end;

procedure TTBMergedItems.Merge;
begin
  if FUnmergeItems = nil then
    FUnmergeItems := TBMergeItems(GetComponentItems(FTarget),
                                  GetComponentItems(FSource),
                                  FOptions);
end;

procedure TTBMergedItems.Unmerge;
var
  List: PTBUnmergeItem;
begin
  if FUnmergeItems <> nil then
  begin
    List := FUnmergeItems;
    FUnmergeItems := nil;
    TBUnmergeItems(GetComponentItems(FTarget),
                   GetComponentItems(FSource),
                   List);
  end;
end;

procedure TTBMergedItems.Dispose;
var
  List: PTBUnmergeItem;
begin
  if FUnmergeItems <> nil then
  begin
    List := FUnmergeItems;
    FUnmergeItems := nil;
    TBFreeUnmergeItems(List);
  end;
end;

{######################################################################
 TTBToolbarMerger
 ######################################################################
}

constructor TTBToolbarMerger.Create(AOwner: TComponent);
begin
  inherited;

  FMergedItems := TList.Create;
end;

destructor TTBToolbarMerger.Destroy;
begin
  Clear;
  FreeAndNil(FMergedItems);

  inherited;
end;

procedure TTBToolbarMerger.Notification(AComponent: TComponent; Operation: TOperation);
var
  Index: Integer;
  OldItem: TTBMergedItems;

  function ObjName(Obj: TComponent): string;
  begin
    if Obj = nil then
      Result := 'nil'
    else if Obj.Name <> '' then
      Result := Obj.Name
    else
      Result := Obj.ClassName + Format('(%p)', [Pointer(Obj)]);
  end;

  function ObjFullName(Obj: TComponent): string;
  begin
    if Obj.Owner = nil then
      Result := ObjName(Obj)
    else
      Result := ObjName(Obj.Owner) + '.' + ObjName(Obj);
  end;

  procedure GiveWarning(Item: TTBMergedItems);
  var
    s: string;
  resourcestring
    S_Header = '{@}:'#13#10#13#10'Component {C} destroyed with'#13#10;
    S_ItemsInto = 'items still merged into {T}.';
    S_ItemsFrom = 'items still merged from {S}.';
    S_FormInfo = #13#10#13#10'You probably forgot to unmerge them in your'#13#10'{O}.FormDestroy event.';
  begin
    s := S_Header;
    if AComponent = Item.Source then
      s := s + S_ItemsInto
    else
      s := s + S_ItemsFrom;

    s := StringReplace(s, '{@}', ObjFullName(Self), [rfReplaceAll]);
    s := StringReplace(s, '{C}', ObjFullName(AComponent), [rfReplaceAll]);
    s := StringReplace(s, '{T}', ObjFullName(Item.Target), [rfReplaceAll]);
    s := StringReplace(s, '{S}', ObjFullName(Item.Source), [rfReplaceAll]);

    if OldItem.Source.Owner is TCustomForm then
      s := s + StringReplace(S_FormInfo, '{O}', ObjName(Item.Source.Owner), [rfReplaceAll]);

    Windows.MessageBox(0, PChar(s), PChar('WARNING'),
      MB_OK or MB_ICONWARNING or MB_SERVICE_NOTIFICATION);
  end;

begin
  inherited;

  if Operation <> opRemove then
    exit;

  for Index := Count - 1 downto 0 do
  begin
    OldItem := Items[Index];
    if (AComponent = OldItem.Target) or
       (AComponent = OldItem.Source) then
    begin
      if (not (csDestroying in OldItem.Target.ComponentState)) or
         (not (csDestroying in OldItem.Source.ComponentState)) then
        // At least one of both is not being destroyed
        GiveWarning(OldItem);

      Delete(Index);
    end;
  end;
end;

function TTBToolbarMerger.GetCount: Integer;
begin
  Result := FMergedItems.Count;
end;

function TTBToolbarMerger.GetItem(Index: Integer): TTBMergedItems;
begin
  Result := TTBMergedItems(FMergedItems[Index]);
end;

function TTBToolbarMerger.IsMerged(Target: TComponent): Integer;
begin
  Result := Count - 1;
  while (Result >= 0) and (Items[Result].Target <> Target) do
    dec(Result);
end;

function TTBToolbarMerger.IsMergedWith(Source: TComponent): Integer;
begin
  Result := Count - 1;
  while (Result >= 0) and (Items[Result].Source <> Source) do
    dec(Result);
end;

procedure TTBToolbarMerger.Merge(Target, Source: TComponent; Options: TTBMergeOptions);
var
  NewItem: TTBMergedItems;
begin
  // Some sanity-checks
  if Application.Terminated or
     (Target = nil) or (csDestroying in Target.ComponentState) or
     (Source = nil) or (csDestroying in Source.ComponentState) or
     (Target = Source) then
    exit;

  // Check if source is target of another operation
  if IsMerged(Source) >= 0 then
    raise Exception.Create('TTBToolbarMerger.Merge: Source is target of another merge operation');

  // Check if target is source of another operation
  if IsMergedWith(Target) >= 0 then
    raise Exception.Create('TTBToolbarMerger.Merge: Target is source of another merge operation');

  // If source is already source of another operation, unmerge that operation
  Unmerge(nil, Source);

  // If target is already target of another operation, unmerge that operation
  Unmerge(Target, nil);

  // Merge the NewItem
  NewItem := TTBMergedItems.Create(Target, Source, Options);

  if NewItem.UnmergeItems = nil then
    // Nothing done, no need to store it
    FreeAndNil(NewItem)
  else
  begin
    // Ask for notifications
    Target.FreeNotification(Self);
    Source.FreeNotification(Self);

    // Add it to the list
    FMergedItems.Add(NewItem);
  end;
end;

procedure TTBToolbarMerger.Delete(Index: Integer);
var
  OldItem: TTBMergedItems;
begin
  // Extract item from the list
  OldItem := Items[Index];
  FMergedItems.Delete(Index);

  // Remove the notifications we have set
  OldItem.Target.RemoveFreeNotification(Self);
  OldItem.Source.RemoveFreeNotification(Self);

  // This will also unmerge the item
  FreeAndNil(OldItem);
end;

procedure TTBToolbarMerger.Unmerge(Target, Source: TComponent);
var
  Index: Integer;
begin
  // Step through all unmerge sets
  for Index := Count - 1 downto 0 do
    if ((Target = nil) or (Items[Index].Target = Target)) and
       ((Source = nil) or (Items[Index].Source = Source)) then
      Delete(Index);
end;

procedure TTBToolbarMerger.UnmergeAll(Comp: TComponent);
var
  Index: Integer;
begin
  // Step through all unmerge sets
  for Index := Count - 1 downto 0 do
    if (Items[Index].Target = Comp) or (Items[Index].Source = Comp) then
      Delete(Index);
end;

procedure TTBToolbarMerger.Clear;
begin
  while Count > 0 do
    Delete(Count - 1);
end;

{######################################################################
 ToolbarMerger
 ######################################################################
}

type
  TGlobalToolbarMerger = class(TTBToolbarMerger)
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

{ The global variable we use as toolbar merger for all operations.

  Note: since GlobalToolbarMerger is owned by the global application object,
  there's no need to free it in a "finalization" block. It will be freed
  automatically as soon as the global application object is being freed.
}
var
  GlobalToolbarMerger: TTBToolbarMerger;

constructor TGlobalToolbarMerger.Create(AOwner: TComponent);
begin
  GlobalToolbarMerger := Self;
  inherited;
end;

destructor TGlobalToolbarMerger.Destroy;
begin
  inherited;
  GlobalToolbarMerger := nil;
end;

function ToolbarMerger: TTBToolbarMerger;
begin
  if GlobalToolbarMerger <> nil then
    Result := GlobalToolbarMerger
  else
    Result := TGlobalToolbarMerger.Create(Application);
end;

end.