I have the following macro below, but need the msxbox to show the text in Blue and in bold
It would be appreciated if someone could amend my code to accomodate this request
It would be appreciated if someone could amend my code to accomodate this request
Code:
Sub Email_Creditors_Report()
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim strBody As String
Dim LR As Long
Dim sumTotal As Double
Dim ws As Worksheet
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim NamesRange As Range
Dim NameCell As Range
Dim NamesList As String
On Error GoTo Cleanup
' Disable screen updating and events
Application.ScreenUpdating = False
Application.EnableEvents = False
Set Sourcewb = ThisWorkbook
Set ws = Sourcewb.Sheets("BR1)
' Store the sum of the range K2:KLR in sumTotal
With ws
LR = .Cells(.Rows.Count, "K").End(xlUp).Row
sumTotal = Application.WorksheetFunction.Sum(.Range("K2:K" & LR))
End With
' Check total
If sumTotal < 10 Then
ShowBoldBlueMessageBox
ShowNoCreditorsMessageBox
GoTo Cleanup
End If
' Copy the worksheet to a new workbook
ws.Copy
Set Destwb = ActiveWorkbook
' Change all cells in the worksheet to values
With Destwb.Sheets(1).UsedRange
.Value = .Value
End With
' Save the new workbook, prepare email
TempFilePath = Environ("TEMP") & "\"
TempFileName = Destwb.Sheets(1).Name & "-Creditors " & Format(Now, "dd-mmm-yy h-mm-ss")
' Define file extension and format
FileExtStr = ".xlsx"
FileFormatNum = 51
' Save the new workbook
Destwb.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
' Create Outlook objects
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
' Prepare email body
Set NamesRange = ws.Range("S1:S5")
For Each NameCell In NamesRange
If Len(NameCell.Value) > 0 Then
NamesList = NamesList & NameCell.Value & ", "
End If
Next NameCell
If Len(NamesList) > 0 Then
NamesList = Left(NamesList, Len(NamesList) - 2) ' Remove the last comma and space
End If
strBody = "Hi " & NamesList & vbNewLine & vbNewLine
strBody = strBody & "Attached Please find Creditors Report. Please attend to those that are 90 days and over" & vbNewLine & vbNewLine
strBody = strBody & "Where you have creditors that are 90 days and over, please provide feedback" & vbNewLine & vbNewLine
strBody = strBody & "Where there are credit balances on the ageing, these must be addressed and allocated as this distorts the ageing" & vbNewLine & vbNewLine
strBody = strBody & "Regards" & vbNewLine & vbNewLine
strBody = strBody & "Howard"
' Create and display/send the email
With OutMail
.To = Join(Application.WorksheetFunction.Transpose(ws.Range("T1:T5").Value), ";")
.CC = ""
.BCC = ""
.Subject = "Creditors Report - " & Format(Now, "dd-mmm-yy h-mm-ss")
.Body = strBody
.Attachments.Add TempFilePath & TempFileName & FileExtStr
.Display ' Use .Send to send automatically or .Display to check email before sending
End With
' Close and delete the temporary workbook
Destwb.Close SaveChanges:=False
Kill TempFilePath & TempFileName & FileExtStr
Cleanup:
' Release Outlook objects
On Error Resume Next
Set OutMail = Nothing
Set OutApp = Nothing
' Enable screen updating and events
Application.ScreenUpdating = True
Application.EnableEvents = True
If Err.Number <> 0 Then
MsgBox "An error occurred: " & Err.Description, vbExclamation
End If
End Sub
Sub ShowNoCreditorsMessageBox()
MsgBox "There are no Creditors 90 Days over, therefore an email will not be generated.", vbInformation + vbOKOnly, "No Creditors Found
End Sub
