Copy from Excel to Outlook as HTML

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