Copy from Excel to Outlook as HTML

Hi All,

My workbook has 5 different sheets and I need to copy the five sheets and paste it into 5 different mails. Preferably as HTML.

The below written code only attaches the different sheets to outlook. I need the HTML below the body of the email. Please note that my range in the sheets varies from workbook to workbook but the sheet names remain the same.

  Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
'BrowseForFolder was a code originally written by Ron De Bruin, I love this function!

Dim ShellApp As Object

'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

'Destroy the Shell Application
Set ShellApp = Nothing

'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select

Exit Function

Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False

End Function

Sub SaveWorksheets()
'saves each worksheet as a separate file in a specific folder.
Dim ThisFolder As String
Dim NameOfFile As String
Dim Period As String
Dim RecipName As String

ThisFolder = BrowseForFolder()

Application.ScreenUpdating = False

Dim ws As Worksheet
Dim wsName As String
For Each ws In ActiveWorkbook.Worksheets
wsName = ws.Name

If wsName <> "Data" Then

Period = ws.Cells(4, 1).Value 'put the row and column numbers of the report date here.
RecipName = ws.Cells(1, 29).Value 'put the row and column numbers of the email address here
NameOfFile = ThisFolder & "\" & "Termination Report " & wsName & " " & Period & ".xlsx"

ws.Select
ws.Copy
ActiveWorkbook.SaveAs Filename:= _
NameOfFile, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Call EmailWorkbooks(RecipName, NameOfFile)
End If

Next ws
End Sub

Sub EmailWorkbooks(RecipName, NameOfFile)

Dim OutApp As Object
Dim OutMail As Object

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

Msg = "Attached is the xyz report for your review. Please let me know if you have any questions" & vbCrLf & vbCrLf _
& "Thanks," & vbCrLf & vbCrLf _
& "Your Name Here" & vbCrLf _
& "Your Title" & vbCrLf _
& "Your contact info"

Subj = "XYZ Report" & " " & Period

On Error Resume Next
With OutMail
.To = RecipName
'.CC =
.Subject = Subj
.Body = Msg
.Attachments.Add (NameOfFile)
.Save
End With
On Error GoTo 0

End Sub

The below written code just copies the sheets to outlook as HTML but doesn't attach the files

Sub InsertSheetContent()
  Dim onePublishObject As PublishObject
  Dim oneSheet As Worksheet
  Dim scriptingObject As Object
  Dim outlookApplication As Object
  Dim outlookMail As Object
  Dim htmlBody As String
  Dim htmlFile As String
  Dim textStream

  Set scriptingObject = CreateObject("Scripting.FileSystemObject")
  Set outlookApplication = CreateObject("Outlook.Application")

  For Each oneSheet In ThisWorkbook.Worksheets
    htmlFile = ThisWorkbook.Path & "\" & ThisWorkbook.Name & "_" & oneSheet.Name & ".html"
    Set onePublishObject = ThisWorkbook.PublishObjects.Add(SourceType:=xlSourceRange, _
                                                            Filename:=htmlFile, _
                                                            Sheet:=oneSheet.Name, _
                                                            Source:=oneSheet.UsedRange.Address, _
                                                            HtmlType:=xlHtmlStatic, _
                                                            DivID:=oneSheet.Name)
    onePublishObject.Publish Create:=True

    Set textStream = scriptingObject.OpenTextFile(htmlFile)
    htmlBody = textStream.ReadAll

    Set outlookMail = outlookApplication.CreateItem(0)
    With outlookMail
        .htmlBody = htmlBody
        .Display
    End With
  Next oneSheet

End Sub

How do I merge both the codes?

Here;s the sample file
https://skydrive.live.com/redir?resi...LXmsEmw9mB3qlk

What I want to do is that I want to copy each sheet to different mails. Also attach the relevant sheet to the mail

Hi -

You can alter the second code you have to something like;

Sub InsertSheetContent()
  Dim onePublishObject As PublishObject
  Dim oneSheet As Worksheet
  Dim scriptingObject As Object
  Dim outlookApplication As Object
  Dim outlookMail As Object
  Dim htmlBody As String
  Dim htmlFile As String
  Dim textStream, fil As String

  Set scriptingObject = CreateObject("Scripting.FileSystemObject")
  Set outlookApplication = CreateObject("Outlook.Application")
  For Each oneSheet In ThisWorkbook.Worksheets
    htmlFile = ThisWorkbook.Path & "\" & ThisWorkbook.Name & "_" & oneSheet.Name & ".html"
    Set onePublishObject = ThisWorkbook.PublishObjects.Add(SourceType:=xlSourceRange, _
                                                            Filename:=htmlFile, _
                                                            Sheet:=oneSheet.Name, _
                                                            Source:=oneSheet.UsedRange.Address, _
                                                            HtmlType:=xlHtmlStatic, _
                                                            DivID:=oneSheet.Name)
    onePublishObject.Publish Create:=True

    Set textStream = scriptingObject.OpenTextFile(htmlFile)
    htmlBody = textStream.ReadAll
    Application.DisplayAlerts = False
    Sheets(oneSheet.Name).Copy
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & oneSheet.Name & ".xlsx"
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
    Set outlookMail = outlookApplication.CreateItem(0)
    With outlookMail
        .htmlBody = htmlBody
        .attachments.Add ThisWorkbook.Path & "\" & oneSheet.Name & ".xlsx"
        .Display
    End With
  Next oneSheet
End Sub

Regards,
Event

Originally Posted by event21

Hi -

You can alter the second code you have to something like;

Sub InsertSheetContent()
  Dim onePublishObject As PublishObject
  Dim oneSheet As Worksheet
  Dim scriptingObject As Object
  Dim outlookApplication As Object
  Dim outlookMail As Object
  Dim htmlBody As String
  Dim htmlFile As String
  Dim textStream, fil As String

  Set scriptingObject = CreateObject("Scripting.FileSystemObject")
  Set outlookApplication = CreateObject("Outlook.Application")
  For Each oneSheet In ThisWorkbook.Worksheets
    htmlFile = ThisWorkbook.Path & "\" & ThisWorkbook.Name & "_" & oneSheet.Name & ".html"
    Set onePublishObject = ThisWorkbook.PublishObjects.Add(SourceType:=xlSourceRange, _
                                                            Filename:=htmlFile, _
                                                            Sheet:=oneSheet.Name, _
                                                            Source:=oneSheet.UsedRange.Address, _
                                                            HtmlType:=xlHtmlStatic, _
                                                            DivID:=oneSheet.Name)
    onePublishObject.Publish Create:=True

    Set textStream = scriptingObject.OpenTextFile(htmlFile)
    htmlBody = textStream.ReadAll
    Application.DisplayAlerts = False
    Sheets(oneSheet.Name).Copy
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & oneSheet.Name & ".xlsx"
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
    Set outlookMail = outlookApplication.CreateItem(0)
    With outlookMail
        .htmlBody = htmlBody
        .attachments.Add ThisWorkbook.Path & "\" & oneSheet.Name & ".xlsx"
        .Display
    End With
  Next oneSheet
End Sub

Regards,
Event

I''ve modified the code to add a subject but it doesn't work
I'm getting a run time error 9
Subscript out of range

Sheets(oneSheet.Name).Copy (IN THIS LINE)

Can any one help.

Sub SendToALL()
  Dim onePublishObject As PublishObject
  Dim oneSheet As Worksheet
  Dim scriptingObject As Object
  Dim outlookApplication As Object
  Dim outlookMail As Object
  Dim htmlBody As String
  Dim htmlFile As String
  Dim textStream, fil As String
                                                         
                                                         
  Today = Format(Now(), "dd-mm-yyyy")
 
 
  Set scriptingObject = CreateObject("Scripting.FileSystemObject")
  Set outlookApplication = CreateObject("Outlook.Application")
  For Each oneSheet In ThisWorkbook.Worksheets
    htmlFile = ThisWorkbook.Path & "\" & ThisWorkbook.Name & "_" & oneSheet.Name & ".html"
    Set onePublishObject = ThisWorkbook.PublishObjects.Add(SourceType:=xlSourceRange, _
                                                            Filename:=htmlFile, _
                                                            Sheet:=oneSheet.Name, _
                                                            Source:=oneSheet.UsedRange.Address, _
                                                            HtmlType:=xlHtmlStatic, _
                                                            DivID:=oneSheet.Name)
    onePublishObject.Publish Create:=True
 
 
 
 
                                                        Dim StrBody As String
                                                        StrBody = " Dear" & " " & UCase(oneSheet.Name) & " " & "All," & vbNewLine & _
                                                        vbNewLine & _
                                                        "Please find attached the <B>'REPORT'<B>"
 
 
                                                 
                                                         
                                                         
    Set textStream = scriptingObject.OpenTextFile(htmlFile)
    htmlBody = textStream.ReadAll
    Application.DisplayAlerts = False
    Sheets(oneSheet.Name).Copy
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & oneSheet.Name & ".xlsx"
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
    Set outlookMail = outlookApplication.CreateItem(0)
    With outlookMail
        .htmlBody = StrBody & htmlBody
        .attachments.Add ThisWorkbook.Path & "\" & oneSheet.Name & ".xlsx"
        .Display
        .Subject = "REPORT" & " " & UCase(oneSheet.Name) & " " & "(" & Today & ")"
         
    End With
  Next oneSheet
End Sub

Your code works like a charm!! Thank YOU!!
How do I hard code the different email addresses into the macro

Hi -

    With outlookMail
        .to="theemailaddress"
        .htmlBody = htmlBody
        .attachments.Add ThisWorkbook.Path & "\" & oneSheet.Name & ".xlsx"
        .Display
    End With

Regards,
Event

I'm getting a run time error 9

Subscript out of range

Sheets(oneSheet.Name).Copy in this line.

Cant really figure out whats wrong

Originally Posted by event21

Hi -

    With outlookMail
        .to="theemailaddress"
        .htmlBody = htmlBody
        .attachments.Add ThisWorkbook.Path & "\" & oneSheet.Name & ".xlsx"
        .Display
    End With

Regards,
Event

This code will work if the email address is same for all the sheets. But in my case I need to send the mails to different addresses

Hi -

Have one sheet to store your email addresses with corresponding sheet name and look up the sheet name within the loop then pass it onto the To fields.

Regards,
Event