C
Christoph_Seemann
I can delete Members of a Distrubution List in the GAL but i can't add
Members Why and How can i do this?
Thank you for your help?
My code:
Sub CoppyVerteilerliste()
Dim appOL As New Outlook.Application 'Outlook-Referenz
Dim oApp As Outlook.Application
Dim oNS As Outlook.NameSpace
Dim oGal As Outlook.AddressList
Dim objNS As Outlook.NameSpace 'Namespace-Referenz
Dim objFld As Outlook.MAPIFolder 'Kontaktordner-Referenz
Dim objDLold As Outlook.DistListItem 'alte (zu bearbeitende)
Verteilerliste
Dim olAdressListe As Outlook.AddressList
Dim oALs As Outlook.AddressLists
Dim olAdressListEintrag As Outlook.AddressEntry
Dim olFolder As Outlook.MAPIFolder
Dim List As Outlook.AddressEntries
Dim Item As Outlook.ContactItem
Dim Name As String
Dim sDLName As String
Dim oEntry As Outlook.AddressEntry
Dim oDL As Outlook.AddressEntry
Dim myRecipients As Outlook.Recipients
Dim mAddressEntry As Outlook.AddressEntry
Dim CdoAddressEntryNewMember
Dim oNewMember As AddressEntry
Dim z As Integer
Dim a As Integer
Set oApp = Outlook.Application
Set oNS = oApp.Session
Set oALs = oNS.AddressLists
Set objNS = appOL.GetNamespace(Type:="MAPI")
Set myTempItem = oApp.CreateItem(olMailItem)
Set myRecipients = myTempItem.Recipients
Set oGal = oALs.Item("Globales Adressbuch")
Set oEntries = oGal.AddressEntries
Set oEntry = oEntries.GetFirst
Set objDLold = oApp.CreateItem(olDistributionListItem)
Set objNS = appOL.GetNamespace("MAPI") 'MAPI-Referenz erstellen
Set olFolder = objNS.GetDefaultFolder(olFolderContacts)
sDLName = InputBox("Bitte den Verteilername Eingeben")
If sDLName = "" Then
MsgBox "Nochmal starten und Verteiler eingeben"
End
Else
Set oDL = oEntries.Item(sDLName)
objDLold.DLName = oDL.Name
Do Until oDL.Members.Count = 0
For z = 2 To oDL.Members.Count 'Schleife durchläuft alle Members von
den Verteilerlisten
'myRecipients.Add oDL.Members.Item(z)
' oDL.Members.Add myRecipients
On Error Resume Next
oDL.Members.Item(z - 1).Delete 'Möglichkeit um die Members
von den Verteilerlisten zu löschen
On Error Resume Next
Next z
If oDL.Members.Count = 1 Then
oDL.Members.Item(1).Delete
On Error Resume Next
End If
Loop
Range("A2").Select
Do Until ActiveCell.Value = ""
myRecipients.Add ActiveCell.Value
ActiveCell.Offset(1, 0).Select
Loop
myRecipients.ResolveAll
MsgBox oDL.Type
' Set oNewMember = oDL.Members.Add("EX", "adler", "(e-mail address removed)")
'myRecipients
MsgBox olFolder.Items.Count
' oDL.Members.Add = mAdressEntry
olFolder.Items.Add myRecipients
If MsgBox("Wollen Dass Die Liste gespeichert wird?", vbQuestion +
vbYesNo) = vbYes Then
objDLold.Save
objDLold.Display
Else
End
End If
End If
End Sub
Members Why and How can i do this?
Thank you for your help?
My code:
Sub CoppyVerteilerliste()
Dim appOL As New Outlook.Application 'Outlook-Referenz
Dim oApp As Outlook.Application
Dim oNS As Outlook.NameSpace
Dim oGal As Outlook.AddressList
Dim objNS As Outlook.NameSpace 'Namespace-Referenz
Dim objFld As Outlook.MAPIFolder 'Kontaktordner-Referenz
Dim objDLold As Outlook.DistListItem 'alte (zu bearbeitende)
Verteilerliste
Dim olAdressListe As Outlook.AddressList
Dim oALs As Outlook.AddressLists
Dim olAdressListEintrag As Outlook.AddressEntry
Dim olFolder As Outlook.MAPIFolder
Dim List As Outlook.AddressEntries
Dim Item As Outlook.ContactItem
Dim Name As String
Dim sDLName As String
Dim oEntry As Outlook.AddressEntry
Dim oDL As Outlook.AddressEntry
Dim myRecipients As Outlook.Recipients
Dim mAddressEntry As Outlook.AddressEntry
Dim CdoAddressEntryNewMember
Dim oNewMember As AddressEntry
Dim z As Integer
Dim a As Integer
Set oApp = Outlook.Application
Set oNS = oApp.Session
Set oALs = oNS.AddressLists
Set objNS = appOL.GetNamespace(Type:="MAPI")
Set myTempItem = oApp.CreateItem(olMailItem)
Set myRecipients = myTempItem.Recipients
Set oGal = oALs.Item("Globales Adressbuch")
Set oEntries = oGal.AddressEntries
Set oEntry = oEntries.GetFirst
Set objDLold = oApp.CreateItem(olDistributionListItem)
Set objNS = appOL.GetNamespace("MAPI") 'MAPI-Referenz erstellen
Set olFolder = objNS.GetDefaultFolder(olFolderContacts)
sDLName = InputBox("Bitte den Verteilername Eingeben")
If sDLName = "" Then
MsgBox "Nochmal starten und Verteiler eingeben"
End
Else
Set oDL = oEntries.Item(sDLName)
objDLold.DLName = oDL.Name
Do Until oDL.Members.Count = 0
For z = 2 To oDL.Members.Count 'Schleife durchläuft alle Members von
den Verteilerlisten
'myRecipients.Add oDL.Members.Item(z)
' oDL.Members.Add myRecipients
On Error Resume Next
oDL.Members.Item(z - 1).Delete 'Möglichkeit um die Members
von den Verteilerlisten zu löschen
On Error Resume Next
Next z
If oDL.Members.Count = 1 Then
oDL.Members.Item(1).Delete
On Error Resume Next
End If
Loop
Range("A2").Select
Do Until ActiveCell.Value = ""
myRecipients.Add ActiveCell.Value
ActiveCell.Offset(1, 0).Select
Loop
myRecipients.ResolveAll
MsgBox oDL.Type
' Set oNewMember = oDL.Members.Add("EX", "adler", "(e-mail address removed)")
'myRecipients
MsgBox olFolder.Items.Count
' oDL.Members.Add = mAdressEntry
olFolder.Items.Add myRecipients
If MsgBox("Wollen Dass Die Liste gespeichert wird?", vbQuestion +
vbYesNo) = vbYes Then
objDLold.Save
objDLold.Display
Else
End
End If
End If
End Sub