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

Question

尝试设置将选择包含电子邮件地址的Excel单元格的VBA代码（每个地址的末尾带有分号，以便在粘贴时允许多封电子邮件），然后将其插入新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