ListBox sortieren, trotzdem Daten richtig auslesen
19.05.2008 14:15:00
stefanseevetal
Ich habe folgende Problem:
Ich Lese mit unten angefügtem Code Kontaktdaten aus Outlook in eine (ListBox mit mehreren Spalten) in einem UserForm und lasse die ListBox gleich korrekt sortieren. Wenn ich nun allerdings einen Eintrag in der ListBox markiere und in in eine Zelle einfügen möchte, dann stimmen die Kontaktdaten nicht mit denen der Auswahl überein. Sprich: Ich wähle bspw. "Hans Müller, Musterstraße" in der ListBox aus und eingefügt wird "Werner Schulz, Bahnhofstr.". Mir ist mittlerweile klar, dass sich dieses Problem aus dem Umsortieren ergibt, da die ListBox jeden Kontakt mit einer Indexnummer abspeichert, bevor ich neu sortiere. Aber wie kann ich das nun umgehen? Ich habe ja alle relevanten Daten in dem Array lstEntries gespeichert, nur weiß ich nicht, wie ich sie dort wieder rausbekomme?
Weiß jemand, ob und wie ich einen in der ListBox angeklicken Eintrag ohne den ListIndex (der mir ja das flasche Ergebnis liefert) auslesen kann?
Wenn das gelingt, könnte ich diesen Eintrag (z.B. den Nachnamen) im Array suchen und mir die dazugehörigen Daten (Adresse, etc.) ausgeben lassen.
Oder hat jemand noch andere Ideen, wie ich das realisieren kann, ohne die Kontakte bspw. in einer Tabelle zwischenzuspeichern? Für das Sortieren einer ListBox finde ich im Netz mehrere interessante Hilfen, aber für korekte Auslesen, finde ich leider nichts!
Also, danke für Eure Hilfe und Gruß,
Stefan
Dim arLst() As Variant
Private Sub UserForm_Activate()
Dim objOutApplication As Object
Dim objOutForlder As Object
Dim objOutContact As Object
Dim intIndex As Integer
With ListBox1
.ColumnCount = 10
.ColumnWidths = "200;80;80;80;80;80;80;80;80"
End With
On Error Resume Next
Set objOutApplication = CreateObject(Class:="Outlook.Application")
If Err.Number 0 Then
MsgBox "Outlook kann nicht erstellt werden." & vbLf & vbLf _
& "Programmabbruch", 16, "Fehler"
Exit Sub
End If
Set objOutForlder = objOutApplication.GetNamespace("MAPI"). _
GetDefaultFolder(10)
If Err.Number 0 Then
MsgBox "Kein Zugriff auf Kontaktordner." & vbLf & vbLf _
& "Programmabbruch", 16, "Fehler"
Exit Sub
End If
On Error GoTo 0
On Error GoTo next_item
For intIndex = 1 To objOutForlder.Items.Count
Set objOutContact = objOutForlder.Items(intIndex)
With objOutContact
ListBox1.AddItem .CompanyName
ListBox1.list(ListBox1.ListCount - 1, 0) = .CompanyName
ListBox1.list(ListBox1.ListCount - 1, 1) = .FirstName
ListBox1.list(ListBox1.ListCount - 1, 1) = .Lastname
ListBox1.list(ListBox1.ListCount - 1, 3) = .BusinessAddressCity
ListBox1.list(ListBox1.ListCount - 1, 4) = .BusinessFaxNumber
ListBox1.list(ListBox1.ListCount - 1, 5) = .BusinessTelephoneNumber
ListBox1.list(ListBox1.ListCount - 1, 6) = .FirstName
ListBox1.list(ListBox1.ListCount - 1, 7) = .Lastname
End With
next_item:
Next intIndex
Dim lstEntries() As Variant
ReDim lstEntries(ListBox1.ListCount, 7) As Variant
lstEntries() = ListBox1.list()
Bubblesort lstEntries(), 0, ListBox1.ListCount - 2, 7
lstEntries() = arLst()
ListBox1.list() = lstEntries()
Set objOutContact = Nothing
Set objOutForlder = Nothing
Set objOutApplication = Nothing
End Sub
Function Bubblesort(list() As Variant, ByVal min As Integer, ByVal max As Integer, ByVal iRows _
As Integer)
Dim done As Boolean
Dim i As Integer, j As Integer
ReDim i_value(iRows) As Variant ' iRows: Anzahl der Spalten ab 0
ReDim arLst(max, iRows) ' iRows: Anzahl der Spalten ab 0
ReDim Preserve list(max + 1, iRows) ' iRows: Anzahl der Spalten ab 0
' Repeat until the list is sorted.
Do
done = True
For i = min + 1 To max
' Compare items i - 1 and i.
If list(i - 1, 0) > list(i, 0) Then
' Swap them.
For j = 0 To 3
i_value(j) = list(i - 1, j)
list(i - 1, j) = list(i, j)
list(i, j) = i_value(j)
Next j
done = False
End If
Next i
Loop Until done
arLst() = list()
End Function
P.S. Denn Code hier habe ich über google gefunden. Er funkioniert super, nur das Auslesen nicht!