VBA Outlook 2000: Function wird nicht richtig ausgeführt

Hallo,

ich habe auf eine Form eine Combo (cmbKontakteOrdner), wo alle Kontakteordner angezeigt werden.
Darüber hinaus befinden sich dort u.a. vier Listenfelder. Das eine heisst lstKontakte und
zweigt alle Kontakte in Form der E-Mail-Adresse an. Die anderen drei heissen lstAN, lstCC und
lstBCC und zeigen jeweils die ausgewählten Kontakte aus lstKontakte in Form einer E-Mail-Adresse an.

Habe folgenden Code gebastelt, aber die Ausführung klappt nicht so, wie ich es mir wünsche.
Es sollten sowohl alle E-Mail-Adressen als auch alle Verteilerlisten unter lstKontakte erscheinen.
Mit meinem Code klappt es nur getrennt. D.h., wenn ich

For Each KontaktOL In OrdnerOL.Items
Me.lstKontakte.AddItem KontaktOL.Email1Address
Next

entferne, dann werden alle E-Mail-Adressen der Verteilerlisten angezeigt.

Wenn ich folgenden Code entferne,

For i% = OrdnerOL.Items.Count To 1 Step -1
If TypeName(OrdnerOL.Items.Item(i)) = \“DistListItem\“ Then \’Verteilerliste gefunden?
Set VL = OrdnerOL.Items.Item(i) \’alte Verteilerliste dem Objekt zuweisen
Set TmpItem = AppOL.CreateItem(olMailItem) \’DummyMailItem erzeugen um ein leeres Recipients-Objekt zu erhalten
Set Rc = TmpItem.Recipients \’das leere Recipients-Objekt zuweisen
For j% = 1 To VL.MemberCount \’alle Mitglieder der Verteilerliste absuchen
strTmp = Trim(LSLeftBack(VL.GetMember(j%).Address, \“(E-Mail)\“)) \’verfälschten OL-Anzeigenamen korrigieren
VLName = VL.DLName
If strTmp <> \“\“ Then \’Name in Verteilerliste nicht leer?
Rc.Add strTmp \’zu Recipients hinzufügen
If Rc.ResolveAll = True Then \’kann aufgelöst werden?
If Rc(1).Address <> \“\“ Then \’EMail-Adresse vorhanden?
Me.lstKontakte.AddItem Rc.Add.Address

End If
End If
End If
Next
End If
Next

dann erscheinen nur die E-Mail-Adressen. Beide gemeinsam funkt leider nicht.

Hätte jemand einen Tipp für mich, was ich anders machen sollte. Danke vielmals für Tipps.

Hier der Code gesamt:

Option Explicit

Dim AppOL As Outlook.Application, NameSpaceOL As Outlook.NameSpace

Private Sub UserForm_Activate()
On Error GoTo Fehlerbehandlung
Dim KontakteOL As Outlook.MAPIFolder, OrdnerOL As Outlook.MAPIFolder
Set AppOL = GetObject(, \“Outlook.Application\“)
Set NameSpaceOL = AppOL.GetNamespace(\“MAPI\“)
Set KontakteOL = NameSpaceOL.GetDefaultFolder(olFolderContacts)
Me.cmbKontakteOrdner.AddItem \“Hauptordner\“
For Each OrdnerOL In KontakteOL.Folders
Me.cmbKontakteOrdner.AddItem OrdnerOL.Name
Next
Me.cmbKontakteOrdner.ListIndex = 0
Exit Sub
Fehlerbehandlung:
If Err = 429 Then
Set AppOL = CreateObject(\“Outlook.Application\“)
End If
Resume Next
End Sub

Private Sub cmbKontakteOrdner_Change()
Dim OrdnerOL As Outlook.MAPIFolder
Dim KontakteOL As Outlook.MAPIFolder
Dim KontaktOL As Outlook.ContactItem
Dim VL As Outlook.DistListItem, VLName As Variant, strTmp As String
Dim TmpItem As Outlook.MailItem \’Mail, um Recipients-Objekt zu erhalten
Dim Rc As Recipients \’Recipients-Objekt
Dim i%, j% \’Zähler für Kontakte und Listenmitglieder
Set AppOL = GetObject(, \“Outlook.Application\“)
Set NameSpaceOL = AppOL.GetNamespace(\“MAPI\“)
Me.lstKontakte.Clear
If Me.cmbKontakteOrdner.ListIndex = 0 Then
Set OrdnerOL = NameSpaceOL.GetDefaultFolder(olFolderContacts)
End If

For Each KontaktOL In OrdnerOL.Items
Me.lstKontakte.AddItem KontaktOL.Email1Address
Next

For i% = OrdnerOL.Items.Count To 1 Step -1
If TypeName(OrdnerOL.Items.Item(i)) = \“DistListItem\“ Then \’Verteilerliste gefunden?
Set VL = OrdnerOL.Items.Item(i) \’alte Verteilerliste dem Objekt zuweisen
Set TmpItem = AppOL.CreateItem(olMailItem) \’DummyMailItem erzeugen um ein leeres Recipients-Objekt zu erhalten
Set Rc = TmpItem.Recipients \’das leere Recipients-Objekt zuweisen
For j% = 1 To VL.MemberCount \’alle Mitglieder der Verteilerliste absuchen
strTmp = Trim(LSLeftBack(VL.GetMember(j%).Address, \“(E-Mail)\“)) \’verfälschten OL-Anzeigenamen korrigieren
VLName = VL.DLName
If strTmp <> \“\“ Then \’Name in Verteilerliste nicht leer?
Rc.Add strTmp \’zu Recipients hinzufügen
If Rc.ResolveAll = True Then \’kann aufgelöst werden?
If Rc(1).Address <> \“\“ Then \’EMail-Adresse vorhanden?
Me.lstKontakte.AddItem Rc.Add.Address
End If
End If
End If
Next
End If
Next
End Sub

Function LSLeftBack(st_parm_fullString As String, st_parm_startString As String)
Dim st_fullString As String
Dim st_startString As String
Dim st_storestring As String
st_fullString = st_parm_fullString
st_startString = st_parm_startString
Dim i_position As Integer
Dim i_tmp As Integer
st_storestring = st_fullString

i_position = InStr(st_fullString, st_startString)

If i_position <> 0 Then
i_tmp = i_position
Do While i_position > 0
st_fullString = Mid(st_fullString, i_position + 1)
i_position = InStr(st_fullString, st_startString)
i_tmp = i_tmp + i_position
Loop

LSLeftBack = Left$(st_storestring, i_tmp – 1)
Else
LSLeftBack = st_fullString
End If

End Function

mfg
BenC