VBA Code: Table Column Formatting for Outlook Email

[Damien Hartzell]

Hello! I'd like to ensure the formatting for the table referenced in the RangetoHTML Funtion keep both Date format for the first column, as well as keeps column width to fit the largest text within each column. Does anyone have pointers or code to accomplish this?

Sub CreateEmailFromExcel()

On Error GoTo Err

Dim rng As Range
Dim OutApp As Outlook.Application
Dim OutMail As MailItem

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

Tenure = Range("H5").Text
Un = Range("H7").Text
weekend = Range("H3").Text

NewHireOccurrences = Range("C7").Value

    NHCA1 = Range("B9").Text
    NHWritten = Range("C9").Text

    NHCA2 = Range("B10").Text
    NHFinal = Range("C10").Text

TotalOccurrenceHours = Range("H10").Value

    TenCA1 = Range("B15").Text
    TenDocCoaching = Range("C15").Text
    TenDocCoachingHoursSince = Range("F15").Value
   
    TenCA2 = Range("B16").Text
    TenWritten = Range("C16").Text
    TenWrittenHoursSince = Range("F16").Value

    TenCA3 = Range("B17").Text
    TenFinal = Range("C17").Text
    TenFinalHoursSince = Range("F17").Value

UnionOccurrences = Range("C20").Value

    UnCA1 = Range("B22").Text
    UnDocCoaching = Range("C22").Text
    UnDocCoachingOccurrencesSince = Range("F22").Text

    UnCA2 = Range("B23").Text
    UnVerbal = Range("C23").Text
    UnVerbalOccurrencesSince = Range("F23").Text

    UnCA3 = Range("B24").Text
    Un1stWritten = Range("C24").Text
    Un1stWrittenOccurrencesSince = Range("F24").Text

    UnCA4 = Range("B25").Text
    Un2ndWritten = Range("C25").Text
    Un2ndWrittenOccurrencesSince = Range("F25").Text
   
    UnCA5 = Range("B26").Text
    UnFinal = Range("C26").Text
    UnFinalOccurrencesSince = Range("F26").Text


FMLAHours = Range("C29").Value

With OutMail
    If Tenure = "New Hire" Then
        .To = ""
        .Subject = "Your Unscheduled and/or FMLA Time"
        .HTMLBody = "Hello. <br><br>" & _
        "Attendance is a vital aspect of employment. It's integral to supporting the larger team and, ultimately, the Members seeking important medical care on the other side of the work we do. <br><br>" & _
        "You currently have " & NewHireOccurrences & " occurrences." & vbNewLine & vbNewLine & _
        "Please, ensure all absences are scheduled and approved in NICE WebStation, as well as that you have the time to cover those absences in Workday. <br><br>" & _
        "Reminders: a) Under 40 Unprotected Paid Unsch includes all unscheduled, paid Time Off Types (including FMLA), b) Over 40 Unprotected includes unscheduled paid time exceeding that 40 hours, as well as Unpaid and Blackout time accrued, and c) any time that indicates Protected is not applying toward 40-hour grace period or to disciplinary action steps. <br><br>" & _
        "Thank you! <br><br>" & _
        RangetoHTML(rng)
        .Display
    End If
   
    If Un = "Yes" Then
        .To = ""
        .Subject = "Your Unscheduled and/or FMLA Time"
        .HTMLBody = "Hello. <br><br>" & _
        "Attendance is a vital aspect of employment. It's integral to supporting the larger team and, ultimately, the Members seeking important medical care on the other side of the work we do. <br><br>" & _
        "You currently have " & UnionOccurrences & " occurrences of unscheduled time. <br><br>" & _
        "Your FMLA usage for the past 12 months is currently " & FMLAHours & " hours. <br><br>" & _
        "Please, ensure all absences are scheduled and approved in NICE WebStation, as well as that you have the time to cover those absences in Workday. <br><br>" & _
        "Thank you! <br><br>" & _
        RangetoHTML(rng)
        .Display
    End If

    If Tenure = "Tenure" Then
        .To = ""
        .Subject = "Your Unscheduled and/or FMLA Time"
        .HTMLBody = "Hello. <br><br>" & _
        "Attendance is a vital aspect of employment. It's integral to supporting the larger team and, ultimately, the Members seeking important medical care on the other side of the work we do. <br><br>" & _
        "You currently have " & TotalOccurrenceHours & " hours of unscheduled time off over your 40-hour grace period. <br><br>" & _
        "Your FMLA usage for the past 12 months is currently " & FMLAHours & " hours. <br><br>" & _
        "Please, ensure all absences are scheduled and approved in NICE WebStation, as well as that you have the time to cover those absences in Workday. <br><br>" & _
        "Reminders: a) Under 40 Unprotected Paid Unsch includes all unscheduled, paid Time Off Types (including FMLA), b) Over 40 Unprotected includes unscheduled paid time exceeding that 40 hours, as well as Unpaid and Blackout time accrued, and c) any time that indicates Protected is not applying toward 40-hour grace period or to disciplinary action steps. <br><br>" & _
        "Thank you! <br><br>" & _
        RangetoHTML(rng)
        .Display
    End If
End With

    Set OutMail = Nothing
   
Err:
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.StatusBar = False
    Application.DisplayStatusBar = oldStatusBar
    Application.EnableEvents = True

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"

Dim ActiveTable As String
    Range("H15").Select
    ActiveTable = ActiveCell.ListObject.Name
                    With Range(ActiveTable).ListObject
                   
                    ''
                        Range("H15:M15").Select
                        Range(Selection, Selection.End(xlDown)).Select

                    ''
                    Selection.Copy
                    End With

'
Set Cell = Nothing

    'Copy the range and create a new workbook to paste the data in
    '''rng.Copy
    On Error GoTo Err
    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
   
Err:
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.StatusBar = False
    Application.DisplayStatusBar = oldStatusBar
    Application.EnableEvents = True
   
End Function

Thanks for your help!

 

[Damien Hartzell]

Anybody know how to accomplish what I'm trying to accomplish? Please!

 

[Damien Hartzell]

I solved my font and size issues using:

<P STYLE='font-family:CalistoMT;font-size:16pt'>

For the date and fit issue, add the following to the With TempWB.Sheets in the RangetoHTML Funciton:
'autofit columns to text:

   Columns("A:F").AutoFit

Also:
'add default signature; this will be listed in htmlbody as "OutMail.HTMLBody"

     OutMail.Display

, then add the following to htmlbody

 & "<br><br>" & _
        OutMail.HTMLBody