Option Explicit
Function Addth(pNumber As String) As String
'Updateby20141027
'Function Posted At:
'https://www.extendoffice.com/documents/excel/2167-excel-convert-cardinal-to-ordinal.html
Select Case CLng(VBA.Right(pNumber, 1))
Case 1: Addth = pNumber & "st"
Case 2: Addth = pNumber & "nd"
Case 3: Addth = pNumber & "rd"
Case Else: Addth = pNumber & "th"
End Select
Select Case VBA.CLng(VBA.Right(pNumber, 2))
Case 11, 12, 13: Addth = pNumber & "th"
End Select
End Function
Sub Email _
(sTo As String, sSub As String, _
sHTML As String, Optional sAttach As Variant, _
Optional sAction As String = "Display", _
Optional sCCs As String, Optional sSender As String)
'v1.49 31 Mar 2023
'https://www.RONDEBRUIN.nl/win/s1/outlook/signature.htm
'with appreciation to ChatGPT for help with the attachment
'logic
'Declare Variables
Dim lngLoop As Long
Dim olApp As Object
Dim olMsg As Object
Dim arrEh As Variant
'Create Email Message
Set olApp = CreateObject("Outlook.Application")
Set olMsg = olApp.CreateItem(0)
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then _
Set olApp = CreateObject("Outlook.Application")
Set olMsg = olApp.CreateItem(0)
With olMsg
.Display
If sSender <> "" Then
.SentOnBehalfOfName = sSender
End If
.To = sTo
.CC = sCCs
.HTMLBody = sHTML & .HTMLBody
.Subject = sSub
If Not IsMissing(sAttach) And Not IsNull(sAttach) Then
If Not IsArray(sAttach) Then
.Attachments.Add sAttach
GoTo Utah
End If
For lngLoop = LBound(sAttach) To UBound(sAttach)
.Attachments.Add sAttach(lngLoop)
Next lngLoop
Utah:
End If
If sAction = "Display" Then
.Display
ElseIf sAction = "Send" Then
.Send
End If
End With
On Error GoTo 0
'Clear Set Variables
Set olApp = Nothing
Set olMsg = Nothing
End Sub