Copy table to htm file and then to outlook

[AngelMike]

I am trying to get a table in full format from Excel to Outlook and my code is not copying to html file first as it should. Can someone please have a look. I am a newbie


Sub Email()

Dim P As String
Dim wb As ThisWorkbook

Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets(2)
Dim new_wb As Workbook
Dim rng As Range
Set rng = Range("A1:B18")
Dim rng2 As Range
Dim OLapp As Object
Dim oLMail As Object
Dim myattachments As Object
Dim olMailItem As Object
Dim myfilenamepath As String
Set OLapp = CreateObject("outlook.application")
'Set oLMail = OLapp.cREATEITEM(olMailItem)
Set olMailItem = OLapp.cREATEITEM(0)
Set myattachments = olMailItem.attachments

P = "C:\Users" & Environ("Username") & "\Desktop\tempfile.htm"
Workbooks.Add
Set new_wb = ActiveWorkbook
'new_wb.Sheets(2).UsedRange.Address

ThisWorkbook.Activate
rng.Copy
new_wb.Activate
ActiveCell.PasteSpecial xlPasteValues
ActiveCell.PasteSpecial xlPasteFormats
ActiveCell.PasteSpecial xlPasteColumnWidths
new_wb.PublishObjects.Add(xlSourceRange, P, new_wb.Sheets(2).Name, new_wb.Sheets(2).UsedRange.Address, xlHtmlStatic).Publish (True)

With olMailItem
.To = Distribution
.CC = ccDistribution
''.Subject = "Test"
.Subject = "Booking Sheet for" & "" & Range("A1").Value & "" & Range("B1").Value
.Body = "This is a test"
''.attachments ()
myfilenamepath = Application.GetOpenFilename()
myattachments.Add myfilenamepath
.Display
End With
End Sub


Thanks for your help!

[Logit]

.
Try this. You will need to edit some of the fields to match your project :

Option Explicit


Sub Mail_Selection_Range_Outlook_Body()
' You need to use this module with the RangetoHTML subroutine.
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
' Thanks to Ron DeBruin and Microsoft for their examples  https://www.rondebruin.nl/


    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail
    Set rng = Nothing
    Dim toList As String
    Dim toCC As String
    Dim toBC As String
    Dim mSub  As String
    Dim strFilename As String
       
    On Error Resume Next
    
    ' Only send the visible cells in the selection.
    'Set rng = Selection.SpecialCells(xlCellTypeVisible)
    ' You can also use a range with the following statement.
    
    '#############################################################
    Set rng = Sheets("Sheet1").Range("A1:B18").SpecialCells(xlCellTypeVisible)  ''//// READ NEXT COMMENT BELOW
    
    'You can edit the above range to change the location of the table that is being copied.
    '#############################################################
    
    'toList = Cells(2, 1)    'gets the TO from col A
    'toCC = Cells(2, 2)      'gets the CC from col B
    'toBC = Cells(2, 3)      'gets the BCC from col C
    'mSub = Cells(2, 4)      'gets the Subject from col D
    
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected. " & _
               vbNewLine & "Please correct and try again.", vbOKOnly
        Exit Sub
    End If


    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With


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


    On Error Resume Next
    With OutMail
    
        .To = ""    'toList        '<-- To Email here
        .CC = ""    'toCC          '<-- CC Email here
        .BCC = ""   'toBC         '<-- BCC Email here
        
        .Subject = "Testing"    'mSub     '<-- Subject Email here
        
        .HTMLBody = "Dear Sir :  " & "<br><br><br>" & _
                    "Please review this latest data : " & "<br><br>" & _
                    "" & RangetoHTML(rng) & "<br><br><br>" & _
                    "Let us know if we can provide any additional information or assistance." & "<br><br>" & _
                    "Sincerely, " & "<br><br>" & _
                    "John Doe"
        .Display    ' Use .Display to view email first, or .Send to send email without viewing first.
        '.Send
        
        .Attachments.Add (Application.ActiveWorkbook.FullName) 'attaches this workbook to email
       
    End With
           
    Application.Goto ActiveWorkbook.Sheets("Sheet1").Range("A1")
    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 workbook to receive the data.
    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 an .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 the RangetoHTML subroutine.
    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.
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function