Bis jetzt war es ziemlich einfach einen Listboxeintrag per Maus innerhalb der Listbox zu verschieben. Doch wollte man mehrere Einträge verschieben, konnte das Verschieben ziemlich zeitaufwendig werden. Mit nachfolgendem Code ist es möglich, mehrere ausgewählte Einträge gleichzeitig zu verschieben. Um das Beispiel auszuprobieren, brauchen Sie eine Form mit einer Listbox "List1" und der Eigenschaft "Multiselec = 1- einfach". Option Explicit ' Benötigte Variablen Dim mark() As Long Dim nIndex As Long Dim newIndex As Long Dim clickindex As Long Dim mclick As Boolean Dim shiftpress As Boolean Dim min As Long Dim max As Long Private Sub Form_Load() ' ein paar Testeinträge erstellen Dim mal As Long For mal = 1 To 40 List1.AddItem "Eintrag " & mal Next ReDim mark(0) mark(0) = -1 End Sub Private Sub clearmark() ' hebt die Markierung aller Einträge in der Listbox auf Dim zahler As Single For zahler = 0 To List1.ListCount - 1 List1.Selected(zahler) = False Next End Sub Private Sub setmark() ' setzt die Markierung der tatäschlich ausgewählten ' Einträge in der Listbox Dim zahler As Single For zahler = 1 To UBound(mark) List1.Selected(mark(zahler)) = True Next End Sub Private Sub List1_MouseDown(Button As Integer, Shift As Integer, _ X As Single, Y As Single) ' Wenn die linke Maustaste gedrückt wurde If Button = 1 Then If mclick = False Then markadd (List1.ListIndex) nIndex = List1.ListIndex clickindex = List1.ListIndex ' wenn die Shifttaste beim Markieren gedrückt ist soll ' die Markierung der anderen Einträge nicht verloren gehen If Shift = 1 Then shiftpress = True Else shiftpress = False If mclick = False Then ReDim mark(0) mark(0) = -1 markadd (List1.ListIndex) clearmark List1.Selected(List1.ListIndex) = True End If End If mclick = True setmark End If End Sub Private Sub List1_MouseMove(Button As Integer, Shift As Integer, _ X As Single, Y As Single) Dim dummy As String Dim i As Single Dim k As Single If mclick = True Then newIndex = List1.ListIndex ' wenn sich der aktuelle Listindex zu dem Listindex ' geändert hat, der aktuell war, als die Maustaste ' gedrückt wurde If newIndex <> nIndex Then Select Case newIndex ' Eintrag wird nach oben in der Liste verschoben Case Is < nIndex ' wenn der oberste markierte Eintrag aus der ' Listbox geschoben werden würde If min - 1 < 0 Then zeug (True) Exit Sub End If For i = 1 To UBound(mark) dummy = List1.List(mark(i) - 1) List1.List(mark(i) - 1) = List1.List(mark(i)) List1.List(mark(i)) = dummy mark(i) = mark(i) - 1 Next ' Eintrag wird nach unten in der Liste verschoben Case Is > nIndex ' wenn der unterste markierte Eintrag aus der ' Listbox geschoben werden würde If max + 1 > List1.ListCount - 1 Then zeug (True) Exit Sub End If For k = 1 To UBound(mark) i = UBound(mark) - k + 1 dummy = List1.List(mark(i) + 1) List1.List(mark(i) + 1) = List1.List(mark(i)) List1.List(mark(i)) = dummy mark(i) = mark(i) + 1 Next End Select zeug (True) End If End If End Sub Private Sub List1_MouseUp(Button As Integer, Shift As Integer, _ X As Single, Y As Single) ' wenn die linke Maustaste wieder losgelassen wurde If Button = 1 Then mclick = False: clickindex = 0 End Sub Private Sub zeug(markierung As Boolean) nIndex = newIndex If markierung = True Then clearmark setmark End If ' kleinster und größter markierter Eintrag ' in der Listbox ermitteln min = mark(1) max = mark(UBound(mark)) List1.ListIndex = newIndex Call List1_MouseDown(1, shiftpress * -1, 0, 0) End Sub Private Function IsSelected(wo As Single) ' wie der Name schon, sagt gibt die Funktion ' zurück, ob ein bestimmter Eintrag markiert ' ist oder nicht Dim mal As Single IsSelected = -1 If UBound(mark) = 0 Then Exit Function For mal = 1 To UBound(mark) If mark(mal) = wo Then IsSelected = mal: Exit For Next End Function Private Sub markadd(wo As Single) Dim dummy As Single Dim position As Single Dim zahler As Single Dim mal As Single position = IsSelected(wo) ' wenn der Eintrag noch nicht im Array ist If position = -1 Then ' Array um eins erhöhen, weil ja eine Zahl mehr reinkommt ReDim Preserve mark(UBound(mark) + 1) ' wenn jetzt das Array max 1 (also zwei Einträge hat) If UBound(mark) = 1 Then mark(1) = wo Else zahler = 0 Do zahler = zahler + 1 If mark(zahler) > wo Then dummy = mark(zahler) mark(zahler) = wo For mal = UBound(mark) To zahler + 1 Step -1 mark(mal) = mark(mal - 1) Next mark(zahler + 1) = dummy Exit Do End If ' wenn durchgelaufen: wo = letzter Eintrag If zahler >= UBound(mark) Then mark(UBound(mark)) = wo Exit Do End If Loop End If ' Eintrag ist bereits im Array vorhanden Else ' Listindex muss immer markiert sein If wo <> newIndex Then If position < UBound(mark) Then For mal = position To UBound(mark) - 1 mark(mal) = mark(mal + 1) Next End If ReDim Preserve mark(UBound(mark) - 1) End If End If End Sub Starten Sie das Projekt, klicken auf einen List-Eintrag und markieren weitere Einträge, indem Sie beim Mausklick die Umschalttaste gedrückt halten. Halten Sie die Umschalttaste weiterhin gedrückt und ziehen die markierten Einräge nun nach oben oder nach unten, um diese innerhalb der ListBox zu verschieben. Dieser Tipp wurde bereits 12.942 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv Vol.6 (einschl. Beispielprojekt!) Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
vb@rchiv CD Vol.6 Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! Online-Update-Funktion Entwickler-Vollversionen u.v.m. Tipp des Monats März 2024 Dieter Otter UTF-8 Konvertierung von Dateien und Strings VB6 selbst verfügt über keine Funktionen zur UTF-8 Konvertierung von Daten. Mit Hilfe des ADODB.Stream-Objekts lassen sich diese fehlenden Funktionen aber schnell nachrüsten. Neu! sevDTA 3.0 Pro SEPA mit Kontonummernprüfung Erstellen von SEPA-Dateien mit integriertem BIC-Verzeichnis und Konto- nummern-Prüfverfahren, so dass ungültige Bankdaten bereits im Vorfeld ermittelt werden können. |
||||||||||||||||
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein. |