E-mail via Outlook with multiple recipients/attachments

The following code will send an e-mail via Outlook to the specified (; separated) recipients, with the specified text as a subject. Body text, (; separated) attachments and a source folder for attachments are optional. You can embed a display name for the attachments by adding ***displayname to the filename (see example below). Without this the filename itself will be displayed. An example call would be:

SendEMail "test_subject", "mike@mikethornton.com;elliot@mikethornton.com", "test_body",ötest1.txt***Summary;test2.txt***detailö,öC:\temp\ö

Public Sub SendEMail(ByVal aSubject As String, ByVal aRecipients As String, Optional ByVal aBody As String = "", Optional ByVal aAttachments As String = "", Optional ByVal aRootPath As String = "")

Dim myO As Outlook.Application
Dim mobjNewMessage As Outlook.MailItem
Dim sRecipient, sAttachment, sDisplayName As String
Dim iMarker, iMarker2 As Integer

On Error GoTo Error_SendEMail
Set myO = CreateObject("Outlook.Application")
Set mobjNewMessage = myO.CreateItem(olMailItem)
mobjNewMessage.Subject = aSubject
mobjNewMessage.Body = aBody
' Loop through ; separated recipients
Do
iMarker = InStr(1, aRecipients, ";", vbTextCompare)
If iMarker = 0 Then
sRecipient = aRecipients
Else
sRecipient = Mid(aRecipients, 1, iMarker - 1)
aRecipients = Mid(aRecipients, iMarker + 1)
End If
If Len(sRecipient) <> 0 Then mobjNewMessage.Recipients.Add sRecipient
Loop While iMarker <> 0

' Loop through ; separated attachments - also look for ***DisplayName
Do
iMarker = InStr(1, aAttachments, ";", vbTextCompare)
If iMarker = 0 Then
sAttachment = aAttachments
Else
sAttachment = Mid(aAttachments, 1, iMarker - 1)
aAttachments = Mid(aAttachments, iMarker + 1)
End If
If Len(sAttachment) <> 0 Then
' Is there an embedded display name?
iMarker2 = InStr(1, sAttachment, "***", vbTextCompare)
If iMarker2 <> 0 Then
sDisplayName = Mid(sAttachment, iMarker2 + 3)
sAttachment = aRootPath + Mid(sAttachment, 1, iMarker2 - 1)
If StrComp(Dir(sAttachment), "", vbTextCompare) <> 0 Then mobjNewMessage.Attachments.Add sAttachment, , , sDisplayName
Else
If StrComp(Dir(aRootPath + sAttachment), "", vbTextCompare) <> 0 Then mobjNewMessage.Attachments.Add aRootPath + sAttachment
End If
End If
Loop While iMarker <> 0

' Send the message
mobjNewMessage.Send

Exit_SendEMail:

Set mobjNewMessage = Nothing
Set myO = Nothing
Exit Sub

Error_SendEMail:
MsgBox Err.Description, , "Send Mail Error"
Resume Exit_SendEMail
End Sub