VBA code to paste clipboard into a newly open email.

[JamesGilchrist]

Hi All,

Not a programmer so apologies if I stumble across any lines/conventions without realizing it.

I looking for some VBA Code for an Excel Macro that does the following.

1. Copies the currently selcted cell range in Excel to the clipborad.
2. Opens a new/blank email in MS Outlook.
3. Pastes the selected cell range (Keep Source Formatting option) into the body of the email.

Many Thanks

James G

 

[Logit]

The new version of Outlook has VBA disabled. That was a MS decision. The following works with the old version of
Outlook :

Option Explicit

Sub CopyRows()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Selection.Copy
    Mail_Selection_Range_Outlook_Body
End Sub

Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String
Set rng = Nothing
' Only send the visible cells in the selection.
Set rng = Selection
If rng Is Nothing Then
    MsgBox "An unknown error has occurred. "
    Exit Sub
End If
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
    .To = "Your email address here in quotes"
    .CC = ""
    .BCC = ""
    .Subject = "Your Subject Here"

    .HTMLBody = "<p>Text above Excel cells" & "<br><br>" & _
                RangetoHTML(rng) & "<br><br>" & _
                "Text below Excel cells.</p>"
    
    ' In place of the following statement, you can use ".Display" to
    ' display the e-mail message.
    '.Send
    .Display
End With
On Error GoTo 0
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    'Close TempWB
    TempWB.Close savechanges:=False
    'Delete the htm file we used in this function
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

[John_w]

Another approach:

Public Sub Copy_Paste_Selection_To_New_Email()

    Dim OutlookApp As Object 'Outlook.Application
    Dim Mail As Object 'Outlook.MailItem
    Dim MailDocument As Object 'Word.Document
    
    Selection.Copy
    
    'Start Outlook if not running
    On Error Resume Next
    Set OutlookApp = GetObject("Outlook.Application")
    If Err <> 0 Then
        Set OutlookApp = CreateObject("Outlook.Application") 'New Outlook.Application
    End If
    On Error GoTo 0
    
    Set Mail = OutlookApp.CreateItem(0)    
    With Mail
        .Subject = "Subject " & Now
        .To = "Email.Address@email.com"
        .Display
    End With
    
    'Paste the copied selection
    Set MailDocument = Mail.GetInspector.WordEditor
    MailDocument.Range.PasteAndFormat Type:=wdFormatOriginalFormatting
    Application.CutCopyMode = False

End Sub