VBA - Email specific range and attach Sheet1

[Clermont]

The below code which I found in my searches is great and supports one of my current tasks. However as task two I only need to send Sheet1 not the whole file. I have been trying to change various ways to get the required result, though continue to fail drastically. Hence if anyone can help I would appreciate it - Many thanks

Sub Mail_Sheet_Outlook_Body()

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object

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

Set rng = Nothing
Set rng = Sheets("TEST").Range("a1:k34")
'Set rng = ActiveSheet.UsedRange
'You can also use a sheet name
'Set rng = Sheets("YourSheet").UsedRange

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

On Error Resume Next
With OutMail
.to = "martyn.pattison@dhl.com"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = RangetoHTML(rng)
.Attachments.Add ActiveWorkbook.FullName
.Send 'or use .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)
' 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 paste 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 xublishsource=", _
"align=left xublishsource=")

'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]

I only need to send Sheet1 not the whole file.

Insert this code before the Outlook code:

    Dim sheetFullName As String    
    sheetFullName = Environ("temp") & "\Sheet1.xlsx"
    Worksheets("Sheet1").Copy
    ActiveWorkbook.SaveAs Filename:=sheetFullName, FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.Close False

and change .Attachments.Add ActiveWorkbook.FullName to:

.Attachments.Add sheetFullName

Add this at the end to delete the Sheet1.xlsx file:

    Kill sheetFullName

 

[Clermont]

John - Many thanks for the direction. Have updated code though still not working, I believe I may be putting the first window in the incorrect place. Placing as below, results in sending email though with no body or file.

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

On Error Resume Next

'***** Mr Excel - Before Outlook Code*****
Dim sheetFullName As String
sheetFullName = Environ("temp") & "\Sheet1.xlsx"
Worksheets("Input").Copy
ActiveWorkbook.SaveAs FileName:=sheetFullName, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close False
'*****

With OutMail
.to = "knebworth110879@gmail.com"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = RangetoHTML(rng)

'.Attachments.Add ActiveWorkbook.FullName
'- using Mr Excel below

'***** Mr Excel *****
Attachments.Add sheetFullName

 

[John_w]

Have updated code though still not working, I believe I may be putting the first window in the incorrect place. Placing as below, results in sending email though with no body or file.

You've put the first piece of code in the correct place. However the second is missing the period (.) at the start. It should be:

.Attachments.Add sheetFullName

Also, temporarily comment out the On Error Resume Next because that will suppress any errors and the code will appear to work without error.

If still not working, post the full code (inside VBA code tags), the error message and say which line it occurs on.

 

[Clermont]

John - I still smile when something works after many years, really appreciated. Had the Kill sheetFullName in the wrong place, though managed to correctly place. Thanks for the festive support, a big help.