TreeView項目のD&D移動

こちらの掲示板の話題です。

使用するイベントは、TreeViewのOnDragDrop,OnDragOver,OnMouseDown,OnStartDragの4つです。
usesにWinapi.CommCtrl（XE以前の場合はCommCtrl）を追加。

項目の移動先が下記のように表示されます。移動先の表示はTVM_SETINSERTMARKメッセージをTreeViewに送る事で実現しています。
TVM_SETINSERTMARKCOLORメッセージで色を変えることも出来るようですが試していません。

  TForm1 = class(TForm)
    TreeView1: TTreeView;
    procedure TreeView1DragDrop(Sender, Source: TObject; X, Y: Integer);
    procedure TreeView1DragOver(Sender, Source: TObject; X, Y: Integer; State:
        TDragState; var Accept: Boolean);
    procedure TreeView1MouseDown(Sender: TObject; Button: TMouseButton; Shift:
        TShiftState; X, Y: Integer);
    procedure TreeView1StartDrag(Sender: TObject; var DragObject: TDragObject);
  private
    FDragNode: TTreeNode;
    FDragMode: Integer;
  public
  end;

procedure TForm1.TreeView1DragDrop(Sender, Source: TObject; X, Y: Integer);
var
  Node: TTreeNode;
begin
  Node := (Sender as TTreeView).DropTarget;
  if Assigned(Node) And Assigned(FDragNode) then
  begin
    if FDragMode = 1 then
    begin
      // 子の一番最後に移動
      FDragNode.MoveTo(Node, naAddChild);
    end else if FDragMode = 2 then
    begin
      // ターゲットの前に同レベルのアイテムとして移動
      FDragNode.MoveTo(Node, naInsert);
    end else if FDragMode = 3 then
    begin
      // ターゲットの同レベル次のアイテムがあればそのアイテムの前に移動
      // 無ければ同レベルの最後に移動
      Node := Node.getNextSibling;
      if Assigned(Node) then
      begin
        FDragNode.MoveTo(Node, naInsert);
      end else begin
        Node := (Sender as TTreeView).DropTarget;
        FDragNode.MoveTo(Node, naAdd);
      end;
    end;
    // ドロップ処理が終わったら挿入マークを消す
    SendMessage((Sender as TTreeView).Handle, TVM_SETINSERTMARK, 1, 0);
  end;
end;

procedure TForm1.TreeView1DragOver(Sender, Source: TObject; X, Y: Integer;
    State: TDragState; var Accept: Boolean);
var
  Node: TTreeNode;
  DragM: Integer;

  rc: TRect;
  ht: THitTests;
begin
  Node := (Sender as TTreeView).GetNodeAt(X, Y);

  Accept := (Sender = Source) And Assigned(Node) And (Node <> FDragNode);

  if Accept then
  begin
    ht := (Sender as TTreeView).GetHitTestInfoAt(X, Y);
    if htOnLabel in ht then
    begin
      DragM := 1;
    end else begin
      rc := Node.DisplayRect(False);
      InflateRect(rc, -1, -1);
      if (rc.Top + rc.Bottom) div 2 > Y then
      begin
        DragM := 2;
      end else begin
        DragM := 3;
      end;
    end;

    if DragM = 1 then
    begin
      // 子に追加するので挿入マークを消す
      SendMessage((Sender as TTreeView).Handle, TVM_SETINSERTMARK, 1, 0);
    end else if DragM = 2 then
    begin
      // ターゲットの上側に挿入マークを表示
      SendMessage((Sender as TTreeView).Handle, TVM_SETINSERTMARK, 0, LPARAM(Node.ItemId));
    end else if DragM = 3 then
    begin
      // ターゲットの下側に挿入マークを表示
      SendMessage((Sender as TTreeView).Handle, TVM_SETINSERTMARK, 1, LPARAM(Node.ItemId));
    end;
    FDragMode := DragM;
  end else begin
    SendMessage((Sender as TTreeView).Handle, TVM_SETINSERTMARK, 1, 0);
    FDragMode := 0;
  end;
end;

procedure TForm1.TreeView1MouseDown(Sender: TObject; Button: TMouseButton;
    Shift: TShiftState; X, Y: Integer);
var
  Node: TTreeNode;
begin
  if Button = mbLeft then
  begin
    FDragNode := (Sender as TTreeView).GetNodeAt(X, Y);
    (Sender as TTreeView).BeginDrag(False, 5);
  end;
end;

procedure TForm1.TreeView1StartDrag(Sender: TObject; var DragObject:
    TDragObject);
begin
  FDragMode := 0;
end;