How to paste email addresses from clipboard into Outlook "To" field? - excel

Question

Trying to setup VBA code that will take a selection of Excel cells which contain email addresses (with a semi-colon at the end of each address to allow for multiple emails when pasted) and insert those into the "To" field in an new Outlook email. When I execute the below code, it only inserts the email addresses into the Body of the Outlook email, not the "To" field. Is there a way to fix this or will I need to approach this in a completely different fashion?
Here is my code:
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

Try creating a string of recipients instead - you can't paste a range to the .To like that.
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