Change Text Format based on Appt Verbage

[mytouchsr]

I have a vba script compiled that will read the appointments for tomorrow and create an email with the appointments for that day. I need to modify it to format the verbage from this appointment to be BOLD RED if it is High Importance. Attached is the vba i am currently using but i am stuck. Any help is appreciated.


Public Sub GetListOfAppointmentsUsingPropertyAccessor()
On Error GoTo On_Error

Dim Session As Outlook.NameSpace
Dim Report As String
Dim AppointmentsFolder As Outlook.Folder
Dim currentItem As Object
Dim currentAppointment As AppointmentItem
Dim Today
Dim Tomorrow
Today = Format(Now(), "mm/dd/yyyy")
Tomorrow = Format(Now() + 1, "mm/dd/YYYY")


Set Session = Application.Session
Set AppointmentsFolder = GetFolderPath("\\SharePoint Lists\Calendar")
'Set AppointmentsFolder = Session.GetDefaultFolder(olFolderCalendar)
'Set AppointmentsFolder = Session.GetDefaultFolder(olFolderCalendar).Folders("Calendar")
'Set Items = Application.ActiveExplorer.CurrentFolder.Items
For Each currentItem In AppointmentsFolder.Items
If (currentItem.Class = olAppointment) Then
Set currentAppointment = currentItem



If currentAppointment.Start = Tomorrow Then
'If currentAppointment.Importance = 2 And currentAppointment.Start = Tomorrow Then
'Selection.Font.FontStyle = "Bold"
Call AddToReportIfNotBlank(Report, "Start", currentAppointment.Start)
Call AddToReportIfNotBlank(Report, "Subject", currentAppointment.Subject)
Call AddToReportIfNotBlank(Report, "Body", currentAppointment.Body)
'ElseIf currentAppointment.Importance = 2 Then
' Call AddToReportIfNotBlank(Report, "Importance", currentAppointment.Importance)

End If

' Call AddToReportIfNotBlank(Report, "StartTimeZone", currentAppointment.StartTimeZone)
' Call AddToReportIfNotBlank(Report, "StartUTC", currentAppointment.StartUTC)
'Call AddToReportIfNotBlank(Report, "Subject", currentAppointment.Subject)
' Call AddToReportIfNotBlank(Report, "UnRead", currentAppointment.UnRead)
' Call AddToReportIfNotBlank(Report, "UserProperties", currentAppointment.UserProperties)

'Report = Report & "--------------------------------------------------------------------------------------------------------"
'Report = Report & vbCrLf & vbCrLf

End If

Next


Call CreateReportAsEmail("CR Region Maintenance Activities " & Today & " ~ " & Tomorrow, Report)

Exiting:
Exit Sub
On_Error:
MsgBox "error=" & Err.Number & " " & Err.Description
Resume Exiting

End Sub
-----------------------------------------------------------------------------------------------------------------------------
Private Function AddToReportIfNotBlank(Report As String, FieldName As String, FieldValue)
Dim Test As String

AddToReportIfNotBlank = ""

If (IsNull(FieldValue) Or FieldValue <> "") Then
AddToReportIfNotBlank = FieldValue
Report = Report & AddToReportIfNotBlank & vbCrLf
End If


'FieldName & " : " & befor vbCrlf on 3 lines above Scott Reid changes
End Function

' VBA SubRoutine which displays a report inside an email
' Programming by Greg Thatcher
-----------------------------------------------------------------------------------------------------------------------------------------
Public Sub CreateReportAsEmail(Title As String, Report As String)
On Error GoTo On_Error

Dim Session As Outlook.NameSpace
Dim mail As MailItem
Dim MyAddress As AddressEntry
Dim Inbox As Outlook.Folder

Set Session = Application.Session
Set Inbox = Session.GetDefaultFolder(olFolderInbox)
Set mail = Inbox.Items.Add("IPM.Mail")

Set MyAddress = Session.CurrentUser.AddressEntry
mail.To = "recipients"
' mail.Recipients.ResolveAll
mail.CC = "recipients"
mail.Subject = Title
mail.Body = "Our Maintenance Activities for this evening/weekend are:" & vbCrLf & vbCrLf & Report
mail.Save
mail.Display


Exiting:
Set Session = Nothing
Exit Sub
On_Error:
MsgBox "error=" & Err.Number & " " & Err.Description
Resume Exiting

End Sub
--------------------------------------------------------------------------------------------------------------
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer

On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function

GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function