Невозможно создать контакт в Outlook с помощью VBA от excel

Question

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

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) = "user@domain.co.uk" 
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) = "user@domain.co.uk" 
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 

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

Приветствия

Ben

Answer 1

Вы должны создать элемент из самого (то есть ваш runoutlook Перспективы 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