Question

尝试设置VBA代码，该代码将选择包含电子邮件地址的Excel单元格（每个地址的末尾带有分号，以便在粘贴时允许多封电子邮件），然后将其插入到“收件人”字段中新的Outlook电子邮件。当我执行以下代码时，它仅将电子邮件地址插入到Outlook电子邮件的正文中，而不是“收件人”字段中。有办法解决这个问题还是我需要以完全不同的方式来解决这个问题？

这是我的代码：

Sub Test2()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Subj As String
    Dim oiInsp As Object
    Dim wdDoc As Object
    Dim oRng As Object

    'Copy the email addresses to the clipboard
    Range("B2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy

    'Create Outlook object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next

    'Trying to add the email address to the "To" field in the email
    With OutMail
        .Display
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range
        .To = oRng.Paste

        'This will resolve all the addresses in the email to ensure they exist in your contacts, otherwise pops up error
        If Not .Recipients.ResolveAll Then
            For Each Recipient In .Recipients
                If Not Recipient.Resolved Then
                    MsgBox Recipient.Name & " could not be resolved"
                End If
            Next
        End If
    End With

    On Error GoTo 0

    Set OutApp = Nothing
    Set OutMail = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
End Sub

Answer 1

尝试创建一串收件人-您不能像这样将范围粘贴到.To。

Sub Test2()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Subj As String
    Dim oiInsp As Object
    Dim wdDoc As Object
    Dim oRng As Object

    Dim lastrow As Long, i As Long
    Dim recipstring As String

    lastrow = Cells(Rows.Count, 2).End(xlUp).Row

    For i = 2 To lastrow
        If i = 2 Then
            recipstring = Range("B" & i).Value
        Else
            recipstring = recipstring & ";" & Range("B" & i).Value
        End If
    Next i

    'Create Outlook object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next

    'Trying to add the email address to the "To" field in the email
    With OutMail
        .Display
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range
        .to = recipstring

        'This will resolve all the addresses in the email to ensure they exist in your contacts, otherwise pops up error
        If Not .Recipients.ResolveAll Then
            For Each Recipient In .Recipients
                If Not Recipient.Resolved Then
                    MsgBox Recipient.Name & " could not be resolved"
                End If
            Next
        End If
    End With

    On Error GoTo 0

    Set OutApp = Nothing
    Set OutMail = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
End Sub

如何将剪贴板中的电子邮件地址粘贴到Outlook“收件人”字段中？

1 个答案: