Question

我有一张excel表，其中包含联系人姓名，公司名称和电子邮件地址列表。我想要做的是通过VBA将这些导入到outlook。我已经做了一些代码来使用excel中的VBA删除联系人文件夹中的当前条目，但是当添加新联系人时，我收到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) = "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

有什么想法吗？会让我的工作变得更轻松，而不必每次都进行自定义导入！

干杯

本

Answer 1

您必须从应用程序本身（即您的runoutlook Outlook对象）创建项目，然后将其移动到所需的文件夹。从遇到错误的位置开始，您可以使用以下

更新代码

// 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

无法使用Excel中的VBA在Outlook中创建联系人

2 个答案: