Die Community zu .NET und Classic VB.
Menü

Tipp-Upload: VB.NET 0371: DragnDrop innerhalb der Anwendung

 von 

Über den Tipp  

Dieser Tippvorschlag ist noch unbewertet.

Der Vorschlag ist in den folgenden Kategorien zu finden:

  • Listensteuerelemente
  • Steuerelemente

Dem Tippvorschlag wurden folgende Schlüsselwörter zugeordnet:
drag

Der Vorschlag wurde erstellt am: 16.05.2009 19:11.
Die letzte Aktualisierung erfolgte am 22.05.2009 22:04.

Zurück zur Übersicht

Beschreibung  

DragnDrop von einem ListenControl zu einem anderen stellt eine hervorragend intuitive und sichere Eingabe-Möglichkeit dar. Es stellt aber auch eine Reihe von Anforderungen an die programmierte Logik:
Als Datenquelle unzulässige Controls müssen ausgeschlossen werden.
Null-Items müssen ausgeschlossen werden.
Ein Item kann nicht in sich selbst oder direkt hinter sich abgelegt werden - bei Treenodes nicht in seinen Parent-Node.
Modifizier-Tasten (Shift/Control/Alt) müssen differenziert zugelassen, und dann auch richtig interpretiert werden
Der aktuell geltende DropEffect (Kopieren/Verschieben/Verknüpfen) muß jederzeit erkennbar sein
Das Ziel-Item muß gehighlighted werden

Diese Anforderungen gelten in fast jedem Fall, wo DragnDrop innerhalb einer Anwendung unterstützt werden soll.

Die Unterstützung des Frameworks für diese Anforderungen ist erstaunlich mangelhaft. Insbesondere das in den DragEventArgs gelieferte DataObjekt tut sich durch vollkommene Nutzlosigkeit hervor, und verleitet auch erfahrene Programmierer zu suboptimalen Lösungen.
Denn statt der amorphen Daten des Dataobjektes sind genau 4 Informationen für einen Drag-Vorgang von Belang:
- das Start-Control
- Position der Maus über dem StartControl zum Zeitpunkt des DragStarts
- das Ziel-Control
- Position der Maus über dem Ziel-Control zum Zeitpunkt des Droppens

Aus diesen Informationen kann in **jedem** Fall das gezogene Item ermittelt werden, und wo es hinsoll.
Die Umsetzung dessen, was der User mit dem Draggen "gemeint" hat, ist dann wieder Sache der eigentlichen Anwendungslogik, und individuell zu programmieren. Jedenfalls die erforderlichen Daten sind problemlos zu ermitteln, anhand des Zustandes der beteiligten Controls.
Andere Informationen (z.B. Text) zu übermitteln ist tendenziell unsicher, und erfordert weitere Vorkehrungen, denn ich kann Text auch im Editor markieren und auf die Anwendung ziehen.

Offensichtlich ist das Framework v.a. auf Draggen von anderen Anwendungen in die eigene hin konzipiert - hier gelten andere Bedingungen, und auch das DataObject macht einen guten Job.

Gewissermaßen skandalös die Tatsache, daß keine Exceptions verarbeitet werden, wenn während des Draggens (einschließlich Drop) Fehler auftreten! Die Anwendung läuft einfach weiter, und der User muß denken, er habe sich vertan.
Solche Fehler bleiben natürlich auch bei der Entwicklung leicht unbemerkt, und Debuggen wird zur sprichwörtlichen Käfer-Suche im Heuhaufen.
Die hier vorgestellte Unterstützung für anwendungs-internes Draggen löst das folgendermaßen:
Die Drop-Verarbeitung wird nicht im ursprünglichen Drop-Event durchgeführt, sondern danach, wenn der eigentliche Drag-Vorgang vollstängig abgeschlossen ist.
(Außerdem werden natürlich obige Anforderungen erfüllt.)

Die Sample-Application demonstriert Drag-Varianten zwischen Label, Treeview, Listbox und auch auf ein zweites Form, mit verschiedenen DropEffekts, assoziiert mit verschiedenen Modifizier-Tasten.

Schwierigkeitsgrad

Schwierigkeitsgrad 3

Verwendete API-Aufrufe:

Download:

Download des Beispielprojektes [25,65 KB]

' Dieser Source stammt von http://www.activevb.de
' und kann frei verwendet werden. Für eventuelle Schäden
' wird nicht gehaftet.

' Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
' Ansonsten viel Spaß und Erfolg mit diesem Source!
'
' Beachten Sie, das vom Designer generierter Code hier ausgeblendet wird.
' In den Zip-Dateien ist er jedoch zu finden.

' ------------ Anfang Projektgruppe DragInApp.sln ------------
' ----------- Anfang Projektdatei DragInApp.vbproj -----------
' --------------- Anfang Datei DragDropper.vb  ---------------
' IDE-Voreinstellungen:
' Option Strict On
' Option Explicit On
' Option Infer On

' Projekt-Voreinstellungen
' Imports System
' Imports System.Drawing
' Imports System.Windows.Forms
' Imports System.Collections.Generic
' Imports System.Linq

''' <summary>
''' kapselt die erforderlichen Funktionen eines DragTargets
''' </summary>
Partial Public Class DragDropper

    ' in diese partial class ist versammelt, was ein DragDropper braucht, um das Drop-Event
    ' abzusetzen
    Public Event Drop As EventHandler(Of DropEventArgs)

    Private Sub OnDrop(ByVal e As DropEventArgs)

        RaiseEvent Drop(Me, e)

    End Sub

    Public Event ValidateDrop As EventHandler(Of ValidateDropEventArgs)

    Private Sub OnValidateDrop(ByVal e As ValidateDropEventArgs)

        Try

            RaiseEvent ValidateDrop(Me, e)

        Catch X As Exception

#If DEBUG Then

            ' Da die IDE Fehler innerhalb von Dragging nicht fängt, hier ein gecodeter Codestop
            ' Die gelbe Markierung kann auf ValidateDrop(this, e) umgesetzt werden (Zeile anklicken,
            ' dann Strg-F9), und der ValidateDrop-Vorgang in Einzelschritten wiederholt
            System.Diagnostics.Debugger.Break()
#End If

            ' Die Release bekommt eine Msgbox
            MessageBox.Show(X.ToString())
            System.Diagnostics.Debugger.Break()

        End Try

    End Sub

#Region "Vars"

    Private _Target As Control
    Private _AllowedEffects As New Dictionary(Of Control, DragDropEffects())()

#End Region
#Region "Initialisation"

    Public Sub New(ByVal DropTarget As Control)

        If DropTarget Is Nothing Then

            Throw New ArgumentNullException("DropTarget", "class DragDropper.ctor:" & vbLf & _
                "Das zur Initialisierung angegebene Control ist null")

        End If

        _Target = DropTarget
        _Target.AllowDrop = True
        AddHandler _Target.DragDrop, AddressOf DropTarget_DragDrop
        AddHandler _Target.DragOver, AddressOf DropTarget_DragOver
        AddHandler _Target.DragLeave, AddressOf DropTarget_DragLeave

    End Sub

    Public Sub AddJob(ByVal Origin As Control, ByVal StandardEffect As DragDropEffects, _
              Optional ByVal ShiftKeyEffect As DragDropEffects = DragDropEffects.None, _
              Optional ByVal ControlKeyEffect As DragDropEffects = DragDropEffects.None, _
              Optional ByVal AltKeyEffect As DragDropEffects = DragDropEffects.None)

        DragDropper.AddOrigin(Origin)

        _AllowedEffects.Add(Origin, New DragDropEffects() { StandardEffect, ShiftKeyEffect, _
            ControlKeyEffect, ControlKeyEffect Or ShiftKeyEffect, AltKeyEffect, AltKeyEffect _
            Or ShiftKeyEffect, AltKeyEffect Or ControlKeyEffect, AltKeyEffect Or _
            ShiftKeyEffect Or ControlKeyEffect})

    End Sub

    Public Sub RemoveJob(ByVal Origin As Control)

        DragDropper.RemoveOrigin(Origin)
        _AllowedEffects.Remove(Origin)

    End Sub

#End Region
#Region "processing DropTarget-Events"

    Private Sub DropTarget_DragLeave(ByVal sender As Object, ByVal e As EventArgs)

        Highlighter.Off()
        _HighlightDelay = Nothing

    End Sub

    Private Sub DropTarget_DragOver(ByVal sender As Object, ByVal e As DragEventArgs)

        If _CurrentOrigin Is Nothing OrElse Not _AllowedEffects.ContainsKey( _
            _CurrentOrigin.Control) Then

            ' Dragging vom falschen Control ablehnen
            e.Effect = DragDropEffects.None
            Return
        End If

        Dim Index = Control.ModifierKeys >> 16

        e.Effect = _AllowedEffects(_CurrentOrigin.Control)(Index)

        Dim Target As DragControl = Nothing

        Try

            Dim BoolDummi As Boolean = SetEffectAdvanced(e, Target, TryCast(sender, _
                TreeView)) OrElse SetEffectAdvanced(e, Target, TryCast(sender, ListView)) _
                OrElse SetEffectAdvanced(e, Target, TryCast(sender, DataGridView)) OrElse _
                SetEffectAdvanced(e, Target, TryCast(sender, ListBox)) OrElse _
                SetEffectAdvanced(e, Target, TryCast(sender, Control))

        Catch X As Exception

#If DEBUG Then

            ' Da die IDE Fehler innerhalb von Dragging nicht fängt, hier ein gecodeter Codestop
            ' Die gelbe Markierung kann auf SetEffectAdvanced() umgesetzt werden (Zeile anklicken,
            ' dann Strg-F9), und der Vorgang in Einzelschritten wiederholt
            System.Diagnostics.Debugger.Break()
#End If

            ' Der Release spendierenwa im Fehlerfall 'ne Msgbox
            MessageBox.Show(X.ToString())
            System.Diagnostics.Debugger.Break()

        End Try

        If e.Effect <> DragDropEffects.None Then
            _CurrentDrag = New ValidateDropEventArgs(_CurrentOrigin, Target, e.Effect)
            OnValidateDrop(_CurrentDrag)

            If _CurrentDrag.Cancel Then e.Effect = DragDropEffects.None
        End If

    End Sub

    Private Sub DropTarget_DragDrop(ByVal sender As Object, ByVal e As DragEventArgs)

        DropTarget_DragLeave(sender, e)
        _CurrentDragDropper = Me

    End Sub

#End Region

End Class ' partial class DragDropper

' ---------------- Ende Datei DragDropper.vb  ----------------
' --------------- Anfang Datei frmDragInApp.vb ---------------
Public Class frmDragInApp

    Private WithEvents _TreeViewDropper As DragDropper
    Private WithEvents _ListboxDropper As DragDropper
    Private _frmDropTarget As New frmDropTarget()

    Public Sub New()

        InitializeComponent()
        Me.Location = Screen.PrimaryScreen.WorkingArea.Location
        TreeView1.Sorted = True
        TreeView1.ExpandAll()

        ' festlegen, von welchem Control mit welchen DropEffects auf welches Zielcontrol
        ' gezogen werden kann
        ' ZielControl: TreeView1
        _TreeViewDropper = New DragDropper(Me.TreeView1)
        _TreeViewDropper.AddJob(lbError, DragDropEffects.Move)
        _TreeViewDropper.AddJob(Label1, DragDropEffects.Copy)

        ' beachte: DragDropEffects.Copy als 4.Argument assoziiert mittm Strg-Modifier
        ' (alle anderen DragJobs haben DragDropEffects.Copy auf Shift)
        _TreeViewDropper.AddJob(TreeView1, DragDropEffects.Move, , DragDropEffects.Copy)

        ' ZielControl: Listbox1
        _ListboxDropper = New DragDropper(Me.Listbox1)
        _ListboxDropper.AddJob(Label1, DragDropEffects.Copy)
        _ListboxDropper.AddJob(Listbox1, DragDropEffects.Move, DragDropEffects.Copy)
        _ListboxDropper.AddJob(TreeView1, DragDropEffects.Move, DragDropEffects.Copy)

        ' ZielControl: _frmDropTarget
        _frmDropTarget.DragDropper.AddJob(Me.Label1, DragDropEffects.Move, DragDropEffects.Copy)
        _frmDropTarget.DragDropper.AddJob(Me.lbError, DragDropEffects.Move, DragDropEffects.Copy)

        ' statisches Event
        AddHandler DragDropper.ValidateDragStart, AddressOf DragDropper_ValidateDragStart

    End Sub

    Private Sub DragDropper_ValidateDragStart(ByVal e As DragDropper.ValidateDragEventArgs)

        If e.Origin.Control Is Me.TreeView1 Then

            ' Besonderheit: für die ersten beiden Nodes soll nur DragDropEffects.Copy möglich sein
            Dim Indx As Integer = Me.TreeView1.Nodes.IndexOf(Me.TreeView1.GetNodeAt(e.Origin.Mouse))

            If Indx >= 0 AndAlso Indx < 2 Then e.Allowed = DragDropEffects.Copy
        End If

    End Sub

    Private Sub ckEnableLBTVDrop_CheckedChanged(ByVal sender As Object, ByVal e As EventArgs) _
        Handles ckEnableLBTVDrop.CheckedChanged, ckDropTargetForm.CheckedChanged

        Dim checked = DirectCast(sender, CheckBox).Checked

        Select Case True

            Case sender Is ckEnableLBTVDrop

                If checked Then
                    _TreeViewDropper.AddJob(Listbox1, DragDropEffects.Move, DragDropEffects.Copy)

                Else

                    _TreeViewDropper.RemoveJob(Listbox1)
                End If

            Case sender Is ckDropTargetForm
                _frmDropTarget.Visible = checked

        End Select

    End Sub

    Private Sub _ListboxDropper_Drop(ByVal Sender As Object, ByVal e As _
        DragDropper.DropEventArgs) Handles _ListboxDropper.Drop

        If e.Origin.Control Is Listbox1 Then

            Dim Indx As Integer = e.Origin.Index

            Listbox1.Items.Insert(e.Target.Index, Listbox1.Items(Indx))

            If e.Effect = DragDropEffects.Move Then
                If e.Target.Index < Indx Then Indx += 1
                Listbox1.Items.RemoveAt(Indx)
            End If

        ElseIf e.Origin.Control Is Label1 Then

            Listbox1.Items.Insert(e.Target.Index, Label1.Name)

        ElseIf e.Origin.Control Is TreeView1 Then

            Dim ndOrigin As TreeNode = TreeView1.GetNodeAt(e.Origin.Mouse)

            Listbox1.Items.Insert(e.Target.Index, ndOrigin.Text)

            If e.Effect = DragDropEffects.Move Then ndOrigin.CutOut()
        End If

    End Sub

    Private Sub _TreeViewDropper_Drop(ByVal Sender As Object, ByVal e As _
        DragDropper.DropEventArgs) Handles _TreeViewDropper.Drop

        Dim ndTarget As TreeNode = TreeView1.GetNodeAt(e.Target.Mouse)
        Dim Nodes As TreeNodeCollection = If(ndTarget Is Nothing, TreeView1.Nodes, ndTarget.Nodes)

        If e.Origin.Control Is Listbox1 Then

            Dim Indx As Integer = e.Origin.Index

            Nodes.Add(Listbox1.Items(Indx).ToString())

            If e.Effect = DragDropEffects.Move Then
                Listbox1.Items.RemoveAt(Indx)
            End If

        ElseIf e.Origin.Control Is Label1 Then

            Nodes.Add(Label1.Name)

        ElseIf e.Origin.Control Is lbError Then

            Nodes.Add(TryCast(DirectCast(lbError, Object), TreeNode))

        ElseIf e.Origin.Control Is TreeView1 Then

            Dim ndOrigin As TreeNode = TreeView1.GetNodeAt(e.Origin.Mouse)

            If e.Effect = DragDropEffects.Move Then
                ndOrigin.Remove()
                Nodes.Add(ndOrigin)

            Else

                Nodes.Add(ndOrigin.CloneByText())
            End If
        End If

        If ndTarget IsNot Nothing Then ndTarget.Expand()

    End Sub

    ''' <summary>
    ''' bei Rechtsklick auf einen Treenode diesen entfernen, Children in den Parent hängen
    ''' </summary>
    Private Sub TreeView1_NodeMouseClick(ByVal sender As Object, ByVal e As _
        TreeNodeMouseClickEventArgs) Handles TreeView1.NodeMouseClick

        If e.Button = MouseButtons.Right Then e.Node.CutOut()

    End Sub

End Class

' ---------------- Ende Datei frmDragInApp.vb ----------------
' --------------- Anfang Datei Highlighter.vb  ---------------
Imports System.Drawing
Imports System.Windows.Forms

''' <summary> Zum Highlighten von Treenodes, ListviewItems etc. </summary>
Public Class Highlighter

    ' Das Highlighten erfolgt durch Farb-Inversion des Target-Rectangles. Ausschalten des Highlights
    ' durch wiederholte Inversion desselben Rectangles. Fehl-Highlighting ergibt sich also, wenn
    ' zwischen Highlight() und Off() das Rectangle anderweitig übermalt wurde.

    Protected Shared _HighlightedRect As Rectangle = Rectangle.Empty

    ' Farb-Inversion ist eine Art "Spiegelung" über eine Farb-Achse.
    ' Dieses komische Rot ergibt (bisher) immer deutliche "Spiegel-Farben"
    Private Shared ReadOnly _AxisColor As Color = Color.FromArgb(255, 0, 127)

    Public Shared Sub Highlight(ByVal Target As Control, ByVal ItemRect As Rectangle)

        If ItemRect.IsEmpty Then
            Highlighter.Off()

        Else

            If Not (TypeOf Target Is TreeView) Then
                ItemRect.Offset(0, -ItemRect.Height \ 2)
                ItemRect.Inflate(0, -2)
            End If

            ItemRect.Intersect(Target.ClientRectangle)

            ' FillReversibleRectangle verwendet bildschirmbezogene Koordinaten, daher muß
            ' ItemRect um
            ' die Bildschirmposition des Controls verschoben werden
            ItemRect.Offset(Target.PointToScreen(Point.Empty))

            If ItemRect.IntersectsWith(_HighlightedRect) Then Return

            ' ist schon highlighted
            If Not _HighlightedRect.IsEmpty Then

                ' altes Highlight löschen
                ControlPaint.FillReversibleRectangle(_HighlightedRect, _AxisColor)
            End If

            _HighlightedRect = ItemRect

            ' neues Highlight setzen
            ControlPaint.FillReversibleRectangle(ItemRect, _AxisColor)
        End If

    End Sub

    Public Shared Sub HighlightAfter(ByVal Target As Control, ByVal ItemRect As Rectangle)

        ItemRect.Offset(0, ItemRect.Height)
        Highlight(Target, ItemRect)

    End Sub

    Public Shared Sub HighlightRow(ByVal Target As Control, ByVal Y As Integer, ByVal Height _
        As Integer)

        Highlighter.Highlight(Target, New Rectangle(0, Y, Target.Width, Height))

    End Sub

    Public Shared Sub Off()

        If _HighlightedRect.IsEmpty Then Return
        ControlPaint.FillReversibleRectangle(_HighlightedRect, _AxisColor)
        _HighlightedRect = Rectangle.Empty

    End Sub

End Class

' ---------------- Ende Datei Highlighter.vb  ----------------
' ------------ Anfang Datei DragDropper.Nested.vb ------------
Imports System.Windows.Forms
Imports System.Drawing
Imports System.ComponentModel
Imports System.Collections.Generic

Partial Public Class DragDropper

    ''' <summary>
    ''' eine spezielle Art von Set: Das erste Incrementieren eines Objekts nimmt es ins Dictionary,
    ''' weitere Hinzufügungen desselben Objekts (per Increment()) stellen nur einen Zähler hoch.
    ''' </summary>
    Private Class CountingSet(Of T)

        Inherits Dictionary(Of T, Integer)

        Public Function Increment(ByVal Key As T) As Integer

            If Not MyBase.ContainsKey(Key) Then
                MyBase.Add(Key, 1)
                Return 1
            End If

            Dim RetVal As Integer = Me(Key) + 1

            Me(Key) = RetVal
            Return RetVal

        End Function

        Public Function Decrement(ByVal Key As T) As Integer

            Dim RetVal As Integer = Me(Key) - 1

            If RetVal = 0 Then
                MyBase.Remove(Key)

            Else

                Me(Key) = RetVal
            End If

            Return RetVal

        End Function

    End Class

    ''' <summary>
    ''' DragControl ist der Baustein, aus dem die EventArgs aufgebaut sind
    ''' Es speichert ein Control, die Mausposition darüber, und, bei 
    ''' Listen-Controls Index des Items unter der Maus
    ''' </summary>
    Public Class DragControl

        Public ReadOnly Control As Control
        Public ReadOnly Mouse As Point

        Private ReadOnly _Index As Integer

        Public Sub New(ByVal Control As Control, ByVal Mouse As Point, ByVal Index As Integer)

            Me.Control = Control
            Me.Mouse = Mouse
            Me._Index = Index

        End Sub

        Public ReadOnly Property Index() As Integer
            Get

                If TypeOf Control Is TreeView Then

                    Throw New NotImplementedException("class DragControl.Index:" & vbLf & _
                        "Beim TreeView kann der Index nicht sinnvoll angegeben werden")

                End If

                Return _Index

            End Get

        End Property

    End Class

    Public Class DropEventArgs

        Inherits EventArgs

        Public ReadOnly Origin As DragControl
        Public ReadOnly Target As DragControl
        Public ReadOnly Effect As DragDropEffects

        Public Sub New(ByVal Origin As DragControl, ByVal Target As DragControl, ByVal Effect _
            As DragDropEffects)

            Me.Origin = Origin
            Me.Target = Target
            Me.Effect = Effect

        End Sub

    End Class

    Public Class ValidateDragEventArgs

        Inherits EventArgs

        Public ReadOnly Origin As DragControl
        Public Allowed As DragDropEffects

        Public Sub New(ByVal Origin As DragControl, ByVal Allowed As DragDropEffects)

            Me.Origin = Origin
            Me.Allowed = Allowed

        End Sub

    End Class

    Public Class ValidateDropEventArgs

        Inherits DropEventArgs

        Public Cancel As Boolean = False

        Public Sub New(ByVal Origin As DragControl, ByVal Target As DragControl, ByVal Effect _
            As DragDropEffects)

            MyBase.New(Origin, Target, Effect)

        End Sub

    End Class
End Class

' ------------- Ende Datei DragDropper.Nested.vb -------------
' ------ Anfang Datei DragDropper.SetEffectAdvanced.vb  ------
Imports System.Collections.Generic
Imports System.Drawing
Imports System.Windows.Forms

Partial Public Class DragDropper

    ' SetEffectAdvanced enthält in verschiedenen Überladungen für verschiedene Controls die
    ' Ermittlung der Item, die Festsetzung des aktuell gültigen DropEffekts (abgestimmt mit
    ' den Modifizier-Tasten), und das Highlighten der Ziel-Items

    Private _HighlightDelay As Nullable(Of Boolean)

    Private Function SetEffectAdvanced(ByVal e As DragEventArgs, ByRef Target As DragControl, _
        ByVal TV As TreeView) As Boolean

        If TV Is Nothing Then Return False

        Dim ptTarget As Point = TV.PointToClient(New Point(e.X, e.Y))
        Dim ndTarget As TreeNode = TV.GetNodeAt(ptTarget)

        If _CurrentOrigin.Control Is TV Then
            If Not _HighlightDelay.HasValue Then

                ' Nach dem ersten DragOver gibt es noch einen Zeichnungsvorgang für den
                ' Drag-Origin-Node.
                ' Das gäbe aber'n Konflikt mittm Highlighter, der also dieses erste Mal aussetzt.
                _HighlightDelay = True
            End If

            If e.Effect = DragDropEffects.Move Then

                ' Spezialfall "SelfDrag bei DragEffect.Move": der TreeNode darf nicht in
                ' seinen Parent, sich selbst oder seine Children abgelegt werden
                Dim ndOrigin As TreeNode = TV.GetNodeAt(_CurrentOrigin.Mouse)

                If ndOrigin.Parent Is ndTarget Then
                    e.Effect = DragDropEffects.None

                Else

                    Dim Nd As TreeNode = ndTarget

                    While Nd IsNot Nothing

                        If ndOrigin Is Nd Then
                            e.Effect = DragDropEffects.None

                            Exit While

                        End If

                        Nd = Nd.Parent

                    End While
                End If
            End If
        End If

        If _HighlightDelay.HasValue AndAlso _HighlightDelay.Value Then
            _HighlightDelay = False

        ElseIf ndTarget IsNot Nothing Then

            Highlighter.Highlight(TV, ndTarget.Bounds)

        Else

            ' Ablage auf oberster Ebene, nicht in einem Treenode
            Dim Y As Integer = 0
            Dim n As Integer = TV.GetNodeCount(False)

            If n > 0 Then

                Dim Nd As TreeNode = TV.Nodes(n - 1)

                While Nd IsNot Nothing
                    Y = Nd.Bounds.Bottom
                    Nd = Nd.NextVisibleNode

                End While
            End If

            Highlighter.HighlightRow(TV, Y, TV.ItemHeight)
        End If

        Target = New DragControl(TV, ptTarget, -1)
        Return True

    End Function

    Private Function SetEffectAdvanced(ByVal e As DragEventArgs, ByRef Target As DragControl, _
        ByVal LV As ListView) As Boolean

        If LV Is Nothing Then Return False

        Dim ptTarget As Point = LV.PointToClient(New Point(e.X, e.Y))
        Dim itmTarget As ListViewItem = LV.GetItemAt(ptTarget.X, ptTarget.Y)
        Dim TargetIndex As Integer = If(itmTarget Is Nothing, LV.Items.Count, itmTarget.Index)

        If _CurrentOrigin.Control Is LV AndAlso e.Effect = DragDropEffects.Move Then

            ' Spezialfall "SelfDrag bei DragEffect.Move": Item nicht auf sich selbst oder
            ' Nachfolger legen
            Dim DeltaIndex As Integer = _CurrentOrigin.Index - TargetIndex

            If DeltaIndex = 0 OrElse DeltaIndex = -1 Then
                e.Effect = DragDropEffects.None
            End If
        End If

        If LV.Items.Count = 0 Then
            Highlighter.HighlightRow(LV, 0, 16)

        ElseIf TargetIndex = LV.Items.Count Then

            Highlighter.HighlightAfter(LV, LV.Items(TargetIndex - 1).Bounds)

        Else

            Highlighter.Highlight(LV, itmTarget.Bounds)
        End If

        Target = New DragControl(LV, ptTarget, TargetIndex)
        Return True

    End Function

    Private Function SetEffectAdvanced(ByVal e As DragEventArgs, ByRef Target As DragControl, _
        ByVal Grid As DataGridView) As Boolean

        If Grid Is Nothing Then Return False

        Dim ptTarget As Point = Grid.PointToClient(New Point(e.X, e.Y))
        Dim HTI As DataGridView.HitTestInfo = Grid.HitTest(ptTarget.X, ptTarget.Y)
        Dim TargetIndex As Integer = If(HTI.RowIndex < 0, Grid.RowCount, HTI.RowIndex)

        If _CurrentOrigin.Control Is Grid AndAlso e.Effect = DragDropEffects.Move Then

            ' Spezialfall "SelfDrag bei DragEffect.Move": Item nicht auf sich selbst oder
            ' Nachfolger legen
            Dim DeltaIndex As Integer = _CurrentOrigin.Index - TargetIndex

            If DeltaIndex = 0 OrElse DeltaIndex = -1 Then
                e.Effect = DragDropEffects.None
            End If
        End If

        If 0 = Grid.RowCount Then
            Highlighter.HighlightRow(Grid, 0, Grid.RowTemplate.Height)

        ElseIf TargetIndex = Grid.RowCount Then

            Highlighter.HighlightAfter(Grid, Grid.GetRowDisplayRectangle(TargetIndex - 1, True))

        Else

            Highlighter.Highlight(Grid, Grid.GetRowDisplayRectangle(TargetIndex, True))
        End If

        Target = New DragControl(Grid, ptTarget, TargetIndex)
        Return True

    End Function

    Private Function SetEffectAdvanced(ByVal e As DragEventArgs, ByRef Target As DragControl, _
        ByVal Lst As ListBox) As Boolean

        If Lst Is Nothing Then Return False

        Dim ptTarget As Point = Lst.PointToClient(New Point(e.X, e.Y))
        Dim TargetIndex As Integer = Lst.IndexFromPoint(ptTarget)

        If TargetIndex < 0 Then TargetIndex = Lst.Items.Count
        If _CurrentOrigin.Control Is Lst AndAlso e.Effect = DragDropEffects.Move Then

            ' Spezialfall "SelfDrag bei DragEffect.Move": Item nicht auf sich selbst oder
            ' Nachfolger legen
            Dim DeltaIndex As Integer = _CurrentOrigin.Index - TargetIndex

            If DeltaIndex = 0 OrElse DeltaIndex = -1 Then
                e.Effect = DragDropEffects.None
            End If
        End If

        If 0 = Lst.Items.Count Then
            Highlighter.HighlightRow(Lst, 0, Lst.ItemHeight)

        ElseIf TargetIndex = Lst.Items.Count Then

            Highlighter.HighlightAfter(Lst, Lst.GetItemRectangle(TargetIndex - 1))

        Else

            Highlighter.Highlight(Lst, Lst.GetItemRectangle(TargetIndex))
        End If

        Target = New DragControl(Lst, ptTarget, TargetIndex)
        Return True

    End Function

    Private Function SetEffectAdvanced(ByVal e As DragEventArgs, ByRef Target As DragControl, _
        ByVal Ctl As Control) As Boolean

        Dim ptTarget As Point = Ctl.PointToClient(New Point(e.X, e.Y))

        Target = New DragControl(Ctl, ptTarget, -1)
        Return True

    End Function

End Class

' ------- Ende Datei DragDropper.SetEffectAdvanced.vb  -------
' ------------ Anfang Datei DragDropper.Shared.vb ------------
Imports System.Drawing
Imports System.Collections.Generic
Imports System.Windows.Forms

Public Delegate Sub SingletonEventHandler(Of T As EventArgs)(ByVal e As T)

Partial Public Class DragDropper

    ' diese partial class enthält nur static Member. Auch das Event ValidateDrag ist public Shared.

    Public Shared Event ValidateDragStart As SingletonEventHandler(Of ValidateDragEventArgs)

    Public Const AllAllowed As DragDropEffects = DragDropEffects.Copy Or DragDropEffects.Link _
        Or DragDropEffects.Move Or DragDropEffects.Scroll

#Region "Vars"

    Private Shared _Origins As New CountingSet(Of Control)()
    Private Shared _CurrentDragDropper As DragDropper = Nothing
    Private Shared _CurrentOrigin As DragControl
    Private Shared _CurrentDrag As ValidateDropEventArgs
    Private Shared _MouseDownArgs As MouseEventArgs = Nothing
    Private Shared _DumData As New DataObject()   ' erf. als Dummi-Arg für Origin.DoDragDrop()

#End Region

    Private Shared Sub AddOrigin(ByVal Origin As Control)

        If _Origins.Increment(Origin) = 1 Then
            AddHandler Origin.MouseDown, AddressOf Origin_MouseDown
            AddHandler Origin.MouseMove, AddressOf Origin_MouseMove
        End If

    End Sub

    Private Shared Sub RemoveOrigin(ByVal Origin As Control)

        If _Origins.Decrement(Origin) = 0 Then
            RemoveHandler Origin.MouseDown, AddressOf Origin_MouseDown
            RemoveHandler Origin.MouseMove, AddressOf Origin_MouseMove
        End If

    End Sub

#Region "processing Origin-Events"

    Private Shared Sub Origin_MouseDown(ByVal sender As Object, ByVal e As MouseEventArgs)

        If e.Button = MouseButtons.Left Then _MouseDownArgs = e

    End Sub

    Private Shared Sub Origin_MouseMove(ByVal sender As Object, ByVal [me] As MouseEventArgs)

        If _MouseDownArgs IsNot Nothing Then
            If [me].Button = MouseButtons.Left Then

                ' Mouse-Move mit gedrückter Links-taste: Dragging starten
                ' für Multi-Item-Controls erstmal checken, ob ein Item unter der Maus ist
                Dim StartIndex As Integer = 0
                Dim pt = _MouseDownArgs.Location

                If TypeOf sender Is ListBox Then
                    StartIndex = DirectCast(sender, ListBox).IndexFromPoint(pt)

                ElseIf TypeOf sender Is ListView Then

                    Dim itmOrigin As ListViewItem = DirectCast(sender, ListView).GetItemAt( _
                        pt.X, pt.Y)

                    StartIndex = If(itmOrigin Is Nothing, -1, itmOrigin.Index)

                ElseIf TypeOf sender Is TreeView Then

                    Dim ndOrigin As TreeNode = DirectCast(sender, TreeView).GetNodeAt(pt)

                    StartIndex = If(ndOrigin Is Nothing, -1, ndOrigin.Index)

                ElseIf TypeOf sender Is DataGridView Then

                    StartIndex = DirectCast(sender, DataGridView).HitTest(pt.X, pt.Y).RowIndex
                End If

                Dim ctlOrigin As Control = DirectCast(sender, Control)

                _CurrentOrigin = New DragControl(ctlOrigin, [me].Location, StartIndex)

                Dim e As New ValidateDragEventArgs(_CurrentOrigin, If(StartIndex < 0, _
                    DragDropEffects.None, AllAllowed))

                RaiseEvent ValidateDragStart(e)

                If e.Allowed <> DragDropEffects.None Then
                    ctlOrigin.DoDragDrop(_DumData, e.Allowed)

                    If _CurrentDragDropper IsNot Nothing Then
                        _CurrentDragDropper.OnDrop(_CurrentDrag)
                        _CurrentDragDropper = Nothing
                    End If
                End If

                _CurrentOrigin = Nothing
            End If

            _MouseDownArgs = Nothing
        End If

    End Sub

#End Region

End Class' partial class DragDropper

' ------------- Ende Datei DragDropper.Shared.vb -------------
' -------------- Anfang Datei frmDropTarget.vb  --------------
Public Class frmDropTarget

    ' den DragDropper public machen, daß man DragJobs adden kann.
    Public ReadOnly DragDropper As DragDropper

    Public Sub New()

        InitializeComponent()
        Me.DragDropper = New DragDropper(Me)
        AddHandler DragDropper.Drop, AddressOf DragDropper_Drop

    End Sub

    Private Sub DragDropper_Drop(ByVal sender As Object, ByVal e As DragDropper.DropEventArgs)

        MessageBox.Show(String.Concat("empfange Drag von ", e.Origin.Control.Name, vbLf, _
            "Übermittelter DropEffekt: ", e.Effect))

        e.Origin.Control.Parent = Me

    End Sub

End Class

' --------------- Ende Datei frmDropTarget.vb  ---------------
' ---------------- Anfang Datei TreenodeX.vb  ----------------
Imports System.Runtime.CompilerServices

Public Module TreenodeX

    ''' <summary>
    ''' Node entfernen, seine Childnodes in den Parent verschieben
    ''' </summary>
    <Extension()> _
        Public Sub CutOut(ByVal Nd As TreeNode)

        Dim Nodes As TreeNodeCollection = If(Nd.Parent Is Nothing, Nd.TreeView.Nodes, _
            Nd.Parent.Nodes)

        For i = Nd.Nodes.Count - 1 To 0 Step -1

            Dim ndChild As TreeNode = Nd.Nodes(i)

            ndChild.Remove()
            Nodes.Add(ndChild)
        Next

        Nd.Remove()

    End Sub

    <Extension()> _
        Public Function CloneByText(ByVal Nd As TreeNode) As TreeNode

        Dim RetVal As New TreeNode(Nd.Text)

        For Each ndChild As TreeNode In Nd.Nodes
            RetVal.Nodes.Add(CloneByText(ndChild))
        Next

        RetVal.Expand()
        Return RetVal

    End Function

End Module

' ----------------- Ende Datei TreenodeX.vb  -----------------
' ------------ Ende Projektdatei DragInApp.vbproj ------------
' ------------- Ende Projektgruppe DragInApp.sln -------------

	

Diskussion  

Diese Funktion ermöglicht es, Fragen, die die Veröffentlichung des Tipps betreffen, zu klären, oder Anregungen und Verbesserungsvorschläge einzubringen. Nach der Veröffentlichung des Tipps werden diese Beiträge nicht weiter verlinkt. Allgemeine Fragen zum Inhalt sollten daher hier nicht geklärt werden.

Um eine Diskussion eröffnen zu können, müssen sie angemeldet sein.