Excel to Outlook VBA

[Mandy Lott]

Hello,

My code works fine however when it copies the range and paste it in the email, the format is all messed up and I have tried everything to fix it. Please see the example I posted of what it should look like verse what it is looking like

Sub Send_Email()

   Dim r As Range
   Set r = Range("B1:U17")

   Dim outlookApp As Outlook.Application
   Set outlookApp = CreateObject("Outlook.Application")

   Dim OutMail As Outlook.MailItem
   Set OutMail = outlookApp.CreateItem(olMailItem)

   Dim StrFileName As String

   Application.DisplayAlerts = False
   Application.ScreenUpdating = False

   Sheets("Agent Detail").Select
  
   ActiveSheet.Outline.ShowLevels RowLevels:=8, ColumnLevels:=8

   r.Select
   r.Copy

   OutMail.Display

   Dim rngDoc As Range
    Set email = OutMail.GetInspector.WordEditor

       With OutMail

          .To = "[EMAIL]none@none.com[/EMAIL]"
          .Subject = "Agent Details"
          .Body = "Hi everybody,"
          .Display

       End With
    email.Range.InsertAfter vbCrLf
    Set ran = email.Range(email.Content.End - 1, email.Content.End - 1)
    ran.PasteAndFormat wdChart
  
    End Sub[code]

<Edited>

 

[SirJB7]

Hi, Mandy Lott!

Welcome to Chandoo forums!
Checked this yet?
http://chandoo.org/forum/forums/new-users-please-start-here.14/

About your question, have you searched in this site for similar problems? I think that this topic has been treated many times.

When posting code please do it between the proper tags "["Code"]" and "["/Code"]" (unquoted), also found in the response toolbar, 5th icon from the right. Thank you.

Regards!

 

[Mandy Lott]

Yes but none of them are working for me.

 

[Monty]

Hello,

My code works fine however when it copies the range and paste it in the email, the format is all messed up and I have tried everything to fix it. Please see the example I posted of what it should look like verse what it is looking like

Sub Send_Email()

   Dim r As Range
   Set r = Range("B1:U17")

   Dim outlookApp As Outlook.Application
   Set outlookApp = CreateObject("Outlook.Application")

   Dim OutMail As Outlook.MailItem
   Set OutMail = outlookApp.CreateItem(olMailItem)

   Dim StrFileName As String

   Application.DisplayAlerts = False
   Application.ScreenUpdating = False

   Sheets("Agent Detail").Select
 
   ActiveSheet.Outline.ShowLevels RowLevels:=8, ColumnLevels:=8

   r.Select
   r.Copy

   OutMail.Display

   Dim rngDoc As Range
    Set email = OutMail.GetInspector.WordEditor

       With OutMail

          .To = "[EMAIL]none@none.com[/EMAIL]"
          .Subject = "Agent Details"
          .Body = "Hi everybody,"
          .Display

       End With
    email.Range.InsertAfter vbCrLf
    Set ran = email.Range(email.Content.End - 1, email.Content.End - 1)
    ran.PasteAndFormat wdChart
 
    End Sub[code]

<Edited>

This function saved me many times.
call this function

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    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