0

我有一个 Excel 表，其中包含联系人姓名、公司名称和电子邮件地址的列表。

我想将这些导出到 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

        ' IT BREAKS AT THIS LINE
        Set olitem = myfolder2.CreateItem(olContactItem)

        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

    ' this is in as otherwise it would only delete a handful
    '  each time it ran for some reason
    Loop Until myfolder2.Items.Count = 0

End Sub
4

2 回答 2

1

您必须从应用程序本身（即您的runoutlookOutlook 对象）创建项目，然后将其移动到所需的文件夹。从遇到错误的地方开始，您可以使用以下内容更新代码

// 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
于 2013-08-19T18:46:23.497 回答
0

这就是我设法让它自己工作的方法

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
于 2013-08-22T14:26:32.560 回答