Drag&Drop между TVirtualStringTree

procedure TfrmMain.VTDragDrop(Sender: TBaseVirtualTree; Source: TObject;
  DataObject: IDataObject; Formats: TFormatArray; Shift: TShiftState;
  Pt: TPoint; var Effect: Integer; Mode: TDropMode);

  // Определяем как поступать с данными. Перемещать, копировать или ссылаться
  procedure DetermineEffect;
  begin
    // Нажаты ли какие-нибудь управляющие клавиши?
    if Shift = [] then
    begin
      // Неа, не нажаты
      // Тогда, если отправитель и получатель - одинаковые объекты (например,
      // если узлы перемещаются из одного и того же дерева), то
      // надо переместить узлы, в противном случае - копировать.
      if Source = Sender then
        Effect := DROPEFFECT_MOVE
      else
        Effect := DROPEFFECT_COPY;
    end
    else begin
      // Нажаты. В зависмости от комбинации решаем что делать
      if (Shift = [ssAlt]) or (Shift = [ssCtrl, ssAlt]) then
        Effect := DROPEFFECT_LINK
      else
        if Shift = [ssCtrl] then
          Effect := DROPEFFECT_COPY
        else
          Effect := DROPEFFECT_MOVE;
    end;
  end;

var
  Attachmode: TVTNodeAttachMode;
  Nodes: TNodeArray;
  i: Integer;
begin
  Nodes := nil;
  // Определяем куда добавлять узел в зависимости от того, куда была
  // брошена ветка.
  case Mode of
    dmAbove:
      AttachMode := amInsertBefore;
    dmOnNode:
      AttachMode := amAddChildLast;
    dmBelow:
      AttachMode := amInsertAfter;
  else
    AttachMode := amNowhere;
  end;
  if DataObject = nil then
  begin
    // Если не пришло интерфейса, то вставка проходит через VCL метод
    if Source is TVirtualStringTree then
    begin
      // Вставка из VT. Можем спокойно пользоваться его методами
      // копирования и перемещения.
      DetermineEffect;
      // Получем список узлов, которые будут участвовать в Drag&Drop
      Nodes := VT2.GetSortedSelection(True);
      // И работаем с каждым
      if Effect = DROPEFFECT_COPY then
      begin
        for i := 0 to High(Nodes) do
          VT2.CopyTo(Nodes, Sender.DropTargetNode, AttachMode, False);
      end
      else
        for i := 0 to High(Nodes) do
          VT2.MoveTo(Nodes, Sender.DropTargetNode, AttachMode, False);
    end
    else if Source is TListBox then
    begin
      // Вставка из объекта какого-то другого класса
      AddVCLText(Sender as TVirtualStringTree,
        (Source as TListBox).Items.Strings[(Source as TListBox).ItemIndex],
        AttachMode);
    end;
  end
  else begin
    // OLE drag&drop.
    // Effect нужен для передачи его источнику drag&drop, чтобы тот решил
    // что он будет делать со своими перетаскиваемыми данными.
    // Например, при DROPEFFECT_MOVE (перемещение) их нужно будет удалить,
    // при копировании - сохранить.
    if Source is TBaseVirtualTree then
      DetermineEffect
    else begin
      if Boolean(Effect and DROPEFFECT_COPY) then
        Effect := DROPEFFECT_COPY
      else
        Effect := DROPEFFECT_MOVE;
    end;
    InsertData(Sender as TVirtualStringTree, DataObject, Formats, Effect, AttachMode);
  end;
end;

procedure TfrmMain.VTDragOver(Sender: TBaseVirtualTree; Source: TObject;
  Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode;
  var Effect: Integer; var Accept: Boolean);

  // Возвращает True, если AParent - дочерний узел ANode.
  function IsNodeParent(AParent, ANode: PVirtualNode): Boolean;
  var
    NextParent: PVirtualNode;
  begin
    NextParent := AParent;
    repeat
      NextParent := NextParent.Parent;
    until
      (NextParent = Sender.RootNode) or (NextParent = nil) or
        (NextParent = ANode);
    Result := ANode = NextParent;
  end;

var
  i: Integer;
  Nodes: TNodeArray;
begin
  Accept := True;
  SetLength(Nodes, 0);
  if (Assigned(Sender.DropTargetNode)) and
    (Sender.DropTargetNode <> Sender.RootNode) then
    Nodes := (Sender as TVirtualStringTree).GetSortedSelection(True);
  if Length(Nodes) > 0 then
  begin
    for i := 0 to Length(Nodes) - 1 do
    begin
      Accept :=
        // Узел не должен быть родителем ветки, в которую производится вставка
        (not IsNodeParent(Sender.DropTargetNode, Nodes))
        // Также, узел не должен равняться ветке-местоназначению вставки.
        // Т.е. мы должны запретить вставку узла в самого себя.
        and (not(Sender.DropTargetNode = Nodes));
      // Отключаем вставку, если хотя бы одно из условий вернуло False
      if not Accept then
        Exit;
    end;
  end;
end;