Обновление групп контактов в Outlook из файла Excel
У меня есть лист в файле Excel с именами и адресами электронной почты.
Мне нужно просмотреть лист и обновить контакты группы Outlook, соответствующие заголовкам.
Sub CreateOutlookContactGroups()
Dim olApp As Object
Dim olNS As Object
Dim olContacts As Object
Dim olDistList As Object
Dim olRecip As Object
Dim lastRow As Long
Dim i As Long
'Get Outlook application object
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olContacts = olNS.GetDefaultFolder(10) '10 = olFolderContacts
'Get last row of email addresses
lastRow = Cells(Rows.Count, "X").End(xlUp).Row
'Loop through each column from E to L in row 4
For i = 5 To 12 'Columns E to L
If Range(Cells(4, i), Cells(4, i)).Value <> "" Then 'Check if there is a value in cell
'Create or Get existing distribution list
On Error Resume Next
Set olDistList = olContacts.Items("IPM.DistList." & Range(Cells(4, i), Cells(4, i)).Value)
If olDistList Is Nothing Then 'Create new distribution list
Set olDistList = olContacts.Items.Add("IPM.DistList")
olDistList.Save
olDistList.Subject = Range(Cells(4, i), Cells(4, i)).Value
End If
On Error GoTo 0
'Add each email address from column X to distribution list if there is an "X" in the corresponding cell
For j = 6 To lastRow 'Row 6 to last row with email addresses
If Range(Cells(j, i), Cells(j, i)).Value = "X" Then 'Check if there is an "X" in cell
Set olRecip = olDistList.AddMember(CStr(Range(Cells(j, "X"), Cells(j, "X")).Value))
olDistList.Save
End If
Next j
End If
Next i
'Release Outlook objects
Set olRecip = Nothing
Set olDistList = Nothing
Set olContacts = Nothing
Set olNS = Nothing
Set olApp = Nothing
MsgBox "Kontakt grupper uppdaterrade!"
End Sub
Код перестает работать в
Set olRecip = olDistList.AddMember(CStr(Range(Cells(j, "X"), Cells(j, "X")).Value))
и выдает ошибку несовместимых типов, но значение является действительным адресом электронной почты.
Как добавление набора данных поможет решить проблему. A6 «Имя фамилия» B6 «Город» C6 «X», если работает, как указано в заголовке C5 D6 «X», если работает, как указано в заголовке D5 E6 «X», если работает, как указано в заголовке E5 F6 «X», если работает, как указано в заголовке F5 G6 "X", если работает, как указано в заголовке G5 H6 "X", если работает, как указано в заголовке H5 I6 "X", если работает, как указано в заголовке I5 J6 "X", если работает, как указано в заголовке J5 K6 "X" ", если работает, как указано в заголовке K5 L6 "X", если работает, как указано в заголовке, L5 X6 "адрес электронной почты" В конце строки в столбце A есть член списка
Ответы 2
Метод DistListItem.AddMember принимает экземпляр класса Recipient для добавления в список. Вы можете использовать метод NameSpace.CreateRecipient, который создает Recipient объект. Имя получателя может быть строкой, представляющей отображаемое имя, псевдоним или полный SMTP-адрес электронной почты получателя. Например:
Sub AddNewMember()
'Adds a member to a new distribution list
Dim objItem As Outlook.DistListItem
Dim objMail As Outlook.MailItem
Dim objRcpnt As Outlook.Recipient
Set objMail = Application.CreateItem(olMailItem)
Set objItem = Application.CreateItem(olDistributionListItem)
'Create recipient for distlist
Set objRcpnt = Application.Session.CreateRecipient("Eugene Astafiev") // or your email address
objRcpnt.Resolve
objItem.AddMember objRcpnt
'Add note to list and display
objItem.DLName = "Northwest Sales Manager"
objItem.Body = "Regional Sales Manager - NorthWest"
objItem.Save
objItem.Display
End Sub
Как мне заставить это работать? Я добавил библиотеку объектов Outlook, но она выдает ошибку «Set objMail = Application.CreateItem (olMailItem)» «Объект не поддерживает атрибут или метод». Какой-то тип ссылки для библиотек объектов должен отсутствовать?
Убедитесь, что вы использовали экземпляр Outlook Application, а не экземпляр Excel.
Обновленный код с измененным ответом Юджина:
Sub CreateOutlookContactGroups2()
Dim olApp As Object
Dim olNS As Object
Dim olContacts As Object
Dim olDistList As Object
Dim olRecip As Object
Dim lastRow As Long
Dim i As Long
'Get Outlook application object
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olContacts = olNS.GetDefaultFolder(10) '10 = olFolderContacts
'Get last row of email addresses
lastRow = Cells(Rows.Count, "X").End(xlUp).Row
'Loop through each column from E to L in row 4
For i = 5 To 12 'Columns E to L
If Range(Cells(4, i), Cells(4, i)).Value <> "" Then 'Check if there is a value in cell
'Create or Get existing distribution list
On Error Resume Next
Set olDistList = olContacts.Items("IPM.DistList." & Range(Cells(4, i), Cells(4, i)).Value)
If olDistList Is Nothing Then 'Create new distribution list
Set olDistList = olContacts.Items.Add("IPM.DistList")
olDistList.Save
olDistList.Subject = Range(Cells(4, i), Cells(4, i)).Value
olDistList.Save
End If
On Error GoTo 0
'Add each email address from column X to distribution list if there is an "X" in the corresponding cell
For j = 6 To lastRow 'Row 6 to last row with email addresses
If Range(Cells(j, i), Cells(j, i)).Value = "X" Then 'Check if there is an "X" in cell
'Set olRecip = olDistList.AddMember(CStr(Range(Cells(j, "X"), Cells(j, "X")).Value))
Set olRecip = Outlook.Application.Session.CreateRecipient(CStr(Range(Cells(j, "X"), Cells(j, "X")).Value))
olRecip.Resolve
olDistList.AddMember olRecip
olDistList.Save
End If
Next j
End If
Set olDistList = Nothing
Next i
'Release Outlook objects
Set olRecip = Nothing
Set olDistList = Nothing
Set olContacts = Nothing
Set olNS = Nothing
Set olApp = Nothing
MsgBox "Kontakt grupper uppdaterade!"
Конец сабвуфера