Excel VBA to open new outlook message with signature and preferred body text format

[morayman]

Hi,

I use an excellent VBA macro from Ron de Bruin to copy and paste a range of cells into the body of an outlook email. It works a breeze, and i'm very happy with it. However, the new mail window this macro opens has Time New Roman as the default font and i would like Calibri, size 11. This new mail woindow also doesnt have my new message signature, and im having to follow the steps in outlook to insert the signature every time i send the mail. Is there a way to tweaqk the code below so that:

1. Text format of the new mail message is Calibri, size 11.
2. The new mail widow contains my signature as it would if i opened a new mail widow from within Outlook



Currently, the excel range goes into the email and i manually change everything, but i have to send many of these mails a day so i was hoping it could have it programmed to my preferences to make life a little easier..!

Here is the macro I use. Appreciate any help! Thanks

-----

Sub ***()


    Selection.EntireRow.Hidden = False
    Range("B2:L15").Select

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

    Set rng = Nothing
    On Error Resume Next
  
    Set rng = Selection.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

    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 = "***"
        .HTMLBody = RangetoHTML(rng)
        .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)

    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"

  
    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

 
    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

 
    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=")

  
    TempWB.Close savechanges:=False

  
    Kill TempFile

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