Attach Excel Worksheet (Not Workbook) to Email

[wpiet]

Is there a way to attach a single worksheet from an Excel workbook to an
Outlook email?
I have a workbook with multiple worksheets, each of which must attach to a
different email. The following code works fine as far as creating & sending
the emails but, for each sheet in the array, I need to attach a copy of the
sheet.
I'm hoping to avoid saving each sheet as a separate workbook but suspect I'm
tilting at windmills.
The "Attachments.Add" line is one of many vain attempts I've made. This one,
as many others, returns Run-time error '438': Object doesn't support this
property or method.

Dim XL As Object
Dim Sht As Worksheet
Dim EmlMsg As MailItem

On Error Resume Next
Set XL = GetObject(, "Excel.Application")

If XL Is Nothing Then
Set XL = CreateObject("Excel.Application")
End If

On Error GoTo 0
XL.Visible = True
XL.Workbooks.Open FileName:="Whatever.xls"

' Send e-mails

For Each Sht In XL.Sheets(Array("OPC", "BP", "WH", "CR", "Oper", "Eng"))
Sht.Activate
Set EmlMsg = CreateItem(0)

With EmlMsg
.To = XL.VLookup(XL.Range("I1"), XL.Range("DstMgrEml"), 2, False)
.Subject = "Something Clever"
.Body = XL.VLookup(XL.Range("I1"), XL.Range("DstMgrEml"), 3,
False) _
& "," & XL.Worksheets("Managers").Range("D8")
.Save
.Attachments.Add XL.Workbook.ActiveSheet
.Send
End With

Set EmlMsg = Nothing
Next Sht

Thanks.

 

[Ken Slovak - [MVP - Outlook]]

As far as I know you will need to save each sheet as a separate workbook,
but you might want to post in an Excel group and see if they have any
suggestions.

 

[wpiet]

Thanks, Ken.
I'll try that.
--
Will

As far as I know you will need to save each sheet as a separate workbook,
but you might want to post in an Excel group and see if they have any
suggestions.

 

[Peter Brauer]

Worksheet Body as Email

I don't know if this is exactly what you are looking for, but I do have code that will take the contents of a single worksheet and insert it into the body of a new message in Outloook:

Sub Mail_Worksheet_As_Outlook_Message()
Dim rng As Range
Dim outApp As Object
Dim outMail As Object
Dim emailWs As Worksheet
Dim qualWs As Worksheet


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

Set rng = Nothing
Set rng = Sheets("SheetName").UsedRange
Set emailWs = Worksheets("Sheet1")
Set qualWs = Worksheets("Sheet2")

Set outApp = CreateObject("Outlook.Application")
outApp.Session.Logon
Set outMail = outApp.CreateItem(0)

On Error Resume Next

With outMail
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.HTMLBody = RangetoHTML(rng)
'.Send
.Display
End With
On Error GoTo 0

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"

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 = False
On Error GoTo 0
End With

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

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=")

tempWb.Close savechanges:=False

Kill tempFile

Set ts = Nothing
Set fso = Nothing
Set tempWb = Nothing

Call Audit

End Function


Does this help?

Peter

 

[Somelad]

Emailing worksheets

HI Peter,

Thanks for the VBA code.
I have copied it into a macro; however am having some trouble running it.
I am a VBA noob and so will have to ask some very basic questions I am afraid!

What do I need to enter between the "" for these variables?
Set rng = Nothing
Set rng = Sheets("SheetName").UsedRange
Set emailWs = Worksheets("Sheet1")
Set qualWs = Worksheets("Sheet2")

Would I be able to enter a cell value from the worksheet as a subject?
.Subject = ""

Thanks
Steve