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