Tipp 0437 Listeneinträge per Drag & Drop verschieben
Autor/Einsender:
Datum:
  Markus Konheisner
17.02.2005
Entwicklungsumgebung:   VB 6
Dieser Tipp zeigt wie man Listeneinträge innerhalb einer ListBox per Drag & Drop manuell verschieben/sortieren kann. Hier ist auch eine Mehrfachauswahl möglich. Beim Verschieben von mehreren Listeneinträgen bleibt der Abstand zwischen den einzelnen Einträgen, nach Beendigung der Drop-Aktion werden die ursprünglich ausgewählten Listeneinträge wieder markiert.
 
Option Explicit

Private Declare Function SendMessage Lib "user32" Alias _
      "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
      ByVal wParam As Long, lParam As Any) As Long

Private Const LB_GETSELCOUNT = &H190
Private Const LB_GETSELITEMS = &H191
Private Const LB_ITEMFROMPOINT = &H1A9
Private Const LB_SELITEMRANGE = &H19B

Private m_lngMouseIndexOld As Long
Private m_blnDrag As Boolean

Private Sub Form_Load()
  Dim i As Integer

  List1.OLEDragMode = vbOLEDragAutomatic
  List1.OLEDropMode = vbOLEDropManual
  For i = 1 To 30
     List1.AddItem CStr(i) & ". Zeile "
  Next i
End Sub

Private Sub List1_MouseMove(Button As Integer, Shift As Integer, _
      X As Single, Y As Single)

  Dim posY As Long
  posY = CLng(Y / Screen.TwipsPerPixelY)
  m_lngMouseIndexOld = SendMessage(List1.hwnd, LB_ITEMFROMPOINT, _
        0, ByVal &H10000 * posY)
End Sub

Private Sub List1_OLEDragOver(Data As DataObject, _
      Effect As Long, Button As Integer, Shift As Integer, _
      X As Single, Y As Single, State As Integer)

  Dim posY              As Long
  Dim lngMouseIndexNew  As Long

  Dim aIndexesSel()     As Long
  Dim lngIndexDif       As Long
  Dim lngIndexNew       As Long
  Dim lngSelItemsCnt    As Long
  Dim n                 As Long
  Dim strTemp           As String

  If m_blnDrag = False Then Exit Sub

  posY = CLng(Y / Screen.TwipsPerPixelY)
  lngMouseIndexNew = SendMessage(List1.hwnd, LB_ITEMFROMPOINT, _
        0, ByVal &H10000 * posY)
  If m_lngMouseIndexOld = lngMouseIndexNew Then Exit Sub

  lngIndexDif = m_lngMouseIndexOld - lngMouseIndexNew
  m_lngMouseIndexOld = lngMouseIndexNew

  lngSelItemsCnt = SendMessage(List1.hwnd, LB_GETSELCOUNT, 0, 0)
  If lngSelItemsCnt < 1 Then Exit Sub

  ReDim aIndexesSel(lngSelItemsCnt - 1)
  SendMessage List1.hwnd, LB_GETSELITEMS, lngSelItemsCnt, _
        aIndexesSel(0)
  If aIndexesSel(0) - lngIndexDif < 0 Or _
        aIndexesSel(UBound(aIndexesSel)) - lngIndexDif >= _
        List1.ListCount Then
    Exit Sub
  End If

  If lngIndexDif < 0 Then
    For n = lngSelItemsCnt - 1 To 0 Step -1
      SendMessage List1.hwnd, LB_SELITEMRANGE, 0, _
           ByVal CLng(n) + &H10000 * CLng(n)
      strTemp = List1.List(aIndexesSel(n))
      lngIndexNew = aIndexesSel(n) - lngIndexDif
      List1.RemoveItem aIndexesSel(n)
      List1.AddItem strTemp, lngIndexNew
    Next n
  End If

  If lngIndexDif > 0 Then
    For n = 0 To lngSelItemsCnt - 1
      SendMessage List1.hwnd, LB_SELITEMRANGE, 0, _
           ByVal CLng(n) + &H10000 * CLng(n)
      strTemp = List1.List(aIndexesSel(n))
      lngIndexNew = aIndexesSel(n) - lngIndexDif
      List1.RemoveItem aIndexesSel(n)
      List1.AddItem strTemp, lngIndexNew
    Next n
  End If

  For n = 0 To UBound(aIndexesSel)
    SendMessage List1.hwnd, LB_SELITEMRANGE, 1, _
          ByVal CLng((aIndexesSel(n)) - lngIndexDif) + _
          &H10000 * CLng((aIndexesSel(n)) - lngIndexDif)
  Next n
End Sub

Private Sub List1_OLEStartDrag(Data As DataObject, _
      AllowedEffects As Long)
  m_blnDrag = True
End Sub

Private Sub List1_OLECompleteDrag(Effect As Long)
  m_blnDrag = False
End Sub
 
Weitere Links zum Thema
Drag & Drop verschiedener Steuerelemente 
Listeneinträge verschieben

Windows-Version
95
98
ME
NT
2000
XP
Vista
Win 7
VB-Version
VBA 5
VBA 6
VB 4/16
VB 4/32
VB 5
VB 6


Download  (3,5 kB) Downloads bisher: [ 893 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Donnerstag, 19. Mai 2011