Невозможно создать контакт в Outlook, используя VBA из Excel

Question

У меня есть лист Excel, в котором есть список имен контактов, названий компаний и адресов электронной почты. Я хочу импортировать их в Outlook через VBA. Я уже сделал некоторый код для удаления текущих записей в папке контактов с помощью VBA из Excel, но при добавлении нового контакта я получаю ошибку времени выполнения 438. Ниже приведен код, который я использую для добавления контакта, а ниже - мой рабочий код удаления.

Sub addnewcontacts()
Dim runoutlook As Outlook.Application
Set runoutlook = CreateObject("Outlook.Application")
Set findnamespace = runoutlook.GetNamespace("MAPI")
Set activefolder = findnamespace.Folders
n = 1
Do Until activefolder.Item(n) = "[e-mail]"
n = n + 1
Loop
Set myfolder = activefolder.Item(n)
Set myfolder2 = myfolder.Folders("Contacts").Folders("CustGBP")
lastrow = Sheets("Data").Range("A" & Sheets("Data").Rows.Count).End(xlUp).Row
For i = 1 To lastrow
Sheets("Sage Data").Activate
If ActiveSheet.Range("C" & i).Value = "" Then
Set olitem = myfolder2.CreateItem(olContactItem) //IT BREAKS AT THIS LINE
With olitem
.FullName = Trim(Range("A" & i).Value)
.Company = Trim(Range("B" & i).Value)
.Email1Address = Range("G" & i).Value
End With
olitem.Save
End If
Next i
End Sub

и рабочий код удаления:

Sub outlookdelete()
Dim runoutlook As Outlook.Application
Set runoutlook = CreateObject("Outlook.Application")
Set findnamespace = runoutlook.GetNamespace("MAPI")
Set activefolder = findnamespace.Folders
n = 1
Do Until activefolder.Item(n) = "[e-mail]"
n = n + 1
Loop
Set myfolder = activefolder.Item(n)
Set myfolder2 = myfolder.Folders("Contacts").Folders("CustGBP")
Do
For Each ContactItem In myfolder2.Items 
ContactItem.Delete
Next ContactItem
Loop Until myfolder2.Items.Count = 0 //this is in as otherwise it would only delete a handful each time it ran for some reason
End Sub

Есть идеи? Сделал бы мою работу намного проще, вместо того, чтобы каждый раз выполнять пользовательский импорт!

ура

Бен

Answer 1

Вы должны создать элемент из самого приложения (т.е. runoutlook Outlook Object), а затем переместите его в нужную папку. Начиная с того места, где вы столкнулись с ошибкой, вы можете обновить свой код следующим

// Creates a contact Item in the default Contacts folder
Set olitem = runoutlook.CreateItem(olContactItem)
With olitem
    .FullName = Trim(Range("A" & i).Value)
    .Company = Trim(Range("B" & i).Value) ' may need to change to "CompanyName" 
    .Email1Address = Range("G" & i).Value
    .Move DestFldr:=myfolder2 // moves the contact to the indicated folder
    .Save
End With

Что касается удаления всех контактов, вы можете попробовать этот код вместо

Do While myfolder2.Items.Count <> 0
    myfolder2.Items.Remove (1)
Loop

Answer 2

Вот как мне удалось заставить его работать самостоятельно

For i = 1 To lastrow
Sheets("Data").Activate
If ActiveSheet.Range("C" & i).Value = "" Then
Set olitem = myfolder2.Items.Add(olContactItem)
With olitem
.FullName = Trim(Range("A" & i).Value)
.CompanyName = Trim(Range("B" & i).Value)
.Email1Address = Range("G" & i).Value
.Save
End With
End If
Application.StatusBar = "Updating Contacts: " & Format(i / lastrow, "Percent") & " Complete"
Next i