Outlook email with Signature and Range of cells as body

[CheekyDevil]

Hi Excel genius'!

I need a variation of the following code to use a range of cells as the email body.

I have the following that adds the signature, but does not add the range of cells. Is this able to be modified to add the cell range?

Thank you to all who can assist with this

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

     On Error Resume Next

    Set rng = Sheet1.Range("A1:B5").SpecialCells(xlCellTypeVisible) 'This piece of code is not working
    On Error GoTo 0

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

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

    On Error Resume Next
    With OutMail

        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = rng & "
" & .HTMLBody
        .Display

    End With

    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

 

[Michael M]

Ron covers adding a range to an email here....

https://www.rondebruin.nl/win/s1/outlook/bmail2.htm

 

[CheekyDevil]

Thanks for that Michael, however I have tried his suggestion and this does not add the Outlook signature. I'd like to add both a range and the default signature to the email

 

[Michael M]

The sig part is....

'Change only Mysig.htm to the name of your signature
    SigString = Environ("appdata") & _
  "\Microsoft\Signatures\Mysig.htm" 'make sure the directory is correct on your machine
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
    On Error Resume Next
    With OutMail
        .To = "ron@debruin.nl"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = strbody & "<br>" & Signature
        .Send    'or use .Display
    End With

shown at

https://www.rondebruin.nl/win/s1/outlook/signature.htm

 

[CheekyDevil]

Thanks for trying to help here Michael however this still wont add the range. It seems like I can either have the range without the signature, or the signature without the range.

If I have:

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next

    Set rng = Sheet1.Range("A1:B5").SpecialCells(xlCellTypeVisible)
    
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If
    

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

    On Error Resume Next

    With OutMail
        .Display
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = ""
        .HTMLBody = RangetoHTML(rng) '.signature 
        .Display
    End With

    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

as Ron suggests, this adds the range I need. If I then add .Signature at the end of the .HTMLBody = RangetoHTML(rng) line, this adds the default signature, but removes the cell range.

Is there not a simple way to set the range of cells and add the default signature?

N.B - I do have the function he outlines in the worksheet module. Perhaps this code needs to be amended to add the signature?

 

[ZVI]

Hi,
You may use the code from this thread: send xls to email
Just replace this line: ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy
by: Sheet1.Range("A1:B5").SpecialCells(xlCellTypeVisible).Copy

 

[Michael M]

There are 2 functions required......
The GetBoiler function...for the signature...
AND
The rangetoHTML Function....for the range of cells
I don't have VBA at the moment so can't play with it.

Function GetBoiler(ByVal sFile As String) As String
'**** Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    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"

    'Copy the range and create a new workbook to past the data in
    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
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    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

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

[Michael M]

Also, you will need to change your sigstring from
Environ("appdata") & "\Microsoft\Signatures\Mysig.htm"

TO something like this....this is mine

C:\Users\Michael\AppData\Roaming\Microsoft\Signatures