send sheet to email as html attachment

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

Hello Readers,

I use the following working code (thanks to ron de bruin) :

Sub Mail_Loadingorder()
Dim OutApp As Object
Dim OutMail As Object
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ThisWorkbook.Sheets("Loadingorder").Range("a1").Value
.CC = ""
.BCC = ""
.Subject = "Loadingorder " & Sheets("Loadingorder").Range("h2").Value
.HTMLBody = SheetToHTML(ActiveSheet)
.Send 'or use .Display
End With
Application.ScreenUpdating = True
Set OutMail = Nothing
Set OutApp = Nothing
End Sub


Now i want to change this to attach the sheet as an html attachment instead
of the
the sheet is standing in the body.

Anyone know this solution..

Greetings
 
copy the sheet to a new workbook. SaveAs HTML and close the workbook. Use
code at Ron's site to attach it to the email and send. Delete the file

You can get most of the code you need by turning on the macro recorder and
performing the actions manually.
 
In fact, his SheettoHTML function already creates the html file

Nwb.SaveAs TempFile, xlHtml

so you would just attach it instead of reading it
 
Untested, but this should be along the lines of what you want:

Sub Mail_ActiveSheet_Attach_as_HTML()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim sStr as String
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
sStr = SheetToHTMLFile(ActiveSheet)
.Attachments.Add sStr
.Send 'or use .Display
End With
Kill sSTr
Application.ScreenUpdating = True
Set OutMail = Nothing
Set OutApp = Nothing
End Sub






Public Function SheetToHTMLFile(sh As Worksheet)
'Function from Dick Kusleika his site
'http://www.dicks-clicks.com/excel/sheettohtml.htm
'Changed by Ron de Bruin 04-Nov-2003
'Modified to just save the file by TWOgilvy 10/24/2005
' and pass back the fully qualified file name
Dim TempFile As String
Dim Nwb As Workbook
Dim myshape As Shape
sh.Copy
Set Nwb = ActiveWorkbook
For Each myshape In Nwb.Sheets(1).Shapes
myshape.Delete
Next
TempFile = Environ$("temp") & "\" & _
Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
Nwb.SaveAs TempFile, xlHtml
Nwb.Close False
Set Nwb = Nothing
SheetToHTMLFile = TempFile
End Function
 
Thanks for your time but does not work...


Tom Ogilvy said:
Untested, but this should be along the lines of what you want:

Sub Mail_ActiveSheet_Attach_as_HTML()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim sStr as String
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
sStr = SheetToHTMLFile(ActiveSheet)
.Attachments.Add sStr
.Send 'or use .Display
End With
Kill sSTr
Application.ScreenUpdating = True
Set OutMail = Nothing
Set OutApp = Nothing
End Sub






Public Function SheetToHTMLFile(sh As Worksheet)
'Function from Dick Kusleika his site
'http://www.dicks-clicks.com/excel/sheettohtml.htm
'Changed by Ron de Bruin 04-Nov-2003
'Modified to just save the file by TWOgilvy 10/24/2005
' and pass back the fully qualified file name
Dim TempFile As String
Dim Nwb As Workbook
Dim myshape As Shape
sh.Copy
Set Nwb = ActiveWorkbook
For Each myshape In Nwb.Sheets(1).Shapes
myshape.Delete
Next
TempFile = Environ$("temp") & "\" & _
Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
Nwb.SaveAs TempFile, xlHtml
Nwb.Close False
Set Nwb = Nothing
SheetToHTMLFile = TempFile
End Function
Click to expand...
 
Try this untested example

Sub Mail_ActiveSheet_HTM_File()
'You must add a reference to the Microsoft outlook Library
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim wb As Workbook
Dim strdate As String

strdate = Format(Now, "dd-mm-yy h-mm-ss")
Application.ScreenUpdating = False

ActiveSheet.Copy
Set wb = ActiveWorkbook
wb.Sheets(1).DrawingObjects.Visible = True
wb.Sheets(1).DrawingObjects.Delete

With wb
.SaveAs "Part of " & ThisWorkbook.Name _
& " " & strdate & ".htm", FileFormat:=xlHtml

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.display 'or use .Display
End With

.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With

Application.ScreenUpdating = True
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
 
As you say, apparently you are not very good with VBA.

In contrast to your failed attempt(s), the routine ran perfectly for me
copied right out of the posting (changing only the email address - didnt'
think Ron wanted a copy of the file <g>).

It appears Ron wants to work with you, so I will leave you with him.
 
Hi Tom

I think the OP have not copy the changed function in the module
Not my address Tom<g>
 
Back
Top