I made the following script to rename incoming mails as a rule in Outlook:
Sub RenameMails(MyMail As MailItem)
Dim strID As String
Dim objMail As Outlook.MailItem
strID = MyMail.EntryID
Set objMail = Application.Session.GetItemFromID(strID)
If Left(objMail.Subject, 4) = "FW: " Then
objMail.Subject = Right(objMail.Subject, Len(objMail.Subject) - 4)
objMail.Subject = "Test: " & objMail.Subject
objMail.Save
End If
Set objMail = Nothing
End Sub
This works for regular incoming mails, but if the mail is an invite to a Teams Meeting, it doesn't change the subject. I suspect it is because it's also not possible to rename the mail itself in outlook, but it is possible to rename the appointment in the calendar.
How do I go from here to renaming the appointment that is associated to this mail?
An invite is not a mailitem.
Option Explicit
Sub RenameIncomingItems(myObj As Object)
Debug.Print
Debug.Print TypeName(myObj)
If Left(myObj.subject, 4) = "FW: " Then
myObj.subject = Right(myObj.subject, Len(myObj.subject) - 4)
myObj.subject = "Test: " & myObj.subject
myObj.Save
Debug.Print " Subject saved: " & myObj.subject
Else
Debug.Print " FW: not found"
End If
End Sub
Private Sub test()
RenameIncomingItems ActiveInspector.CurrentItem
End Sub
I made it work like this:
Sub RenameMails(objMail As Object)
Dim myAppt As Outlook.AppointmentItem
If (Left(objMail.Subject, 4) = "FW: ") Then
objMail.Subject = Right(objMail.Subject, Len(objMail.Subject) - 4)
objMail.Subject = "Test: " & objMail.Subject
objMail.Save
End If
If (objMail.Class = olMeetingRequest) Then
Set myAppt = objMail.GetAssociatedAppointment(True)
If (Left(myAppt.Subject, 4) = "FW: ") Then
myAppt.Subject = Right(myAppt.Subject, Len(myAppt.Subject) - 4)
myAppt.Subject = "Test: " & myAppt.Subject
myAppt.Save
End If
End If
End Sub
Related
I found code in How to get the sender’s email address from one or more emails in Outlook?.
I need to get the e-mail addresses of the CC field as well.
Sub GetSmtpAddressOfSelectionEmail()
Dim xExplorer As Explorer
Dim xSelection As Selection
Dim xItem As Object
Dim xMail As MailItem
Dim xAddress As String
Dim xFldObj As Object
Dim FilePath As String
Dim xFSO As Scripting.FileSystemObject
On Error Resume Next
Set xExplorer = Application.ActiveExplorer
Set xSelection = xExplorer.Selection
For Each xItem In xSelection
If xItem.Class = olMail Then
Set xMail = xItem
xAddress = xAddress & VBA.vbCrLf & " " & GetSmtpAddress(xMail)
End If
Next
If MsgBox("Sender SMTP Address is: " & xAddress & vbCrLf & vbCrLf & "Do you want to export the address list to a txt file? ", vbYesNo, "Kutools for Outlook") = vbYes Then
Set xFldObj = CreateObject("Shell.Application").BrowseforFolder(0, "Select a Folder", 0, 16)
Set xFSO = New Scripting.FileSystemObject
If xFldObj Is Nothing Then Exit Sub
FilePath = xFldObj.Items.Item.Path & "\Address.txt"
Close #1
Open FilePath For Output As #1
Print #1, "Sender SMTP Address is: " & xAddress
Close #1
Set xFSO = Nothing
Set xFldObj = Nothing
MsgBox "Address list has been exported to：" & FilePath, vbOKOnly + vbInformation, "Kutools for Outlook"
End If
End Sub
Function GetSmtpAddress(Mail As MailItem)
Dim xNameSpace As Outlook.NameSpace
Dim xEntryID As String
Dim xAddressEntry As AddressEntry
Dim PR_SENT_REPRESENTING_ENTRYID As String
Dim PR_SMTP_ADDRESS As String
Dim xExchangeUser As exchangeUser
On Error Resume Next
GetSmtpAddress = ""
Set xNameSpace = Application.Session
If Mail.sender.Type <> "EX" Then
GetSmtpAddress = Mail.sender.Address
Else
PR_SENT_REPRESENTING_ENTRYID = "http://schemas.microsoft.com/mapi/proptag/0x00410102"
xEntryID = Mail.PropertyAccessor.BinaryToString(Mail.PropertyAccessor.GetProperty(PR_SENT_REPRESENTING_ENTRYID))
Set xAddressEntry = xNameSpace.GetAddressEntryFromID(xEntryID)
If xAddressEntry Is Nothing Then Exit Function
If xAddressEntry.AddressEntryUserType = olExchangeUserAddressEntry Or xAddressEntry.AddressEntryUserType = olExchangeRemoteUserAddressEntry Then
Set xExchangeUser = xAddressEntry.GetExchangeUser()
If xExchangeUser Is Nothing Then Exit Function
GetSmtpAddress = xExchangeUser.PrimarySmtpAddress
Else
PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
GetSmtpAddress = xAddressEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
End If
End If
End Function
How could I adapt the code to include the e-mail addresses from the CC field as well?
I tried setting Recipients but couldn't get the desired outcome.
You need to replace the GetSmtpAddress function with your own where you could get the CC recipients in the following way (a raw sketch):
Function GetSmtpAddress(Mail As MailItem) as String
Dim emailAddress as String
Dim recipient as Outlook.Recipient
Dim recipients as Outlook.Recipients
Set recipients = Mail.Recipients
For Each recipient In recipients
If recipient.Type = olCC Then
If recipient.AddressEntry.Type = "EX" Then
emailAddress = emailAddress & " " & recipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress
Else
emailAddress = emailAddress & " " & recipient.Address
End If
End If
Next
Return emailAddress
End Function
You may find the How To: Fill TO,CC and BCC fields in Outlook programmatically article helpful.
Loop through all recipients in the MailItem.Recipients collection, check that Recipient.Type = olCC. For each Recipient object use Recipient.Address. Note that you can end up with EX type addresses (instead of SMTP). Check that Recipient.AddressEntry.Type is "SMTP". If it is not, use Recipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress instead (do check for nulls).
I have the below code which counts the number of attachments in an email, but the problem is it also counts embedded images. Is there a way to exclude embedded images, so they do not get counted?
Sub CountAttachmentsinSelectedEmails()
Dim olSel As Selection
Dim oMail As Object
Dim AttCount As Long
Dim strMsg As String
Set olSel = Outlook.Application.ActiveExplorer.Selection
For Each oMail In olSel
'To confirm if the selected items are all emails
If oMail.Class <> olMail Then
strMsg = "Please select mail items only!"
nRes = MsgBox(strMsg, vbOKOnly + vbExclamation)
Exit Sub
End If
'Get the total number of the attachments in selected emails
AttCount = oMail.Attachments.Count + AttCount
Next
strMsg = "There are " & AttCount & " attachments in the " & olSel.Count & " selected emails."
nRes = MsgBox(strMsg, vbOKOnly + vbInformation, "Count Attachments")
End Sub
Try the next adapted code, please:
Sub CountAttachmentsinSelectedEmails()
Dim olSel As Selection, nRes As VbMsgBoxResult
Dim oMail As Object, AttCount As Long, strMsg As String
Set olSel = Outlook.Application.ActiveExplorer.Selection
For Each oMail In olSel
'To confirm if the selected items are all emails
If oMail.Class <> olMail Then
strMsg = "Please select mail items only!"
nRes = MsgBox(strMsg, vbOKOnly + vbExclamation)
Exit Sub
End If
'Get the total number of NOT embeded attachments in selected emails
Dim objAtt As Outlook.Attachment
For Each objAtt In oMail.Attachments
If Not IsEmbedded(objAtt) Then
AttCount = AttCount + 1
Debug.Print "Not embedded attachment name: " & objAtt.DisplayName & vbCrLf & _
" from email " & oMail.Subject & vbCrLf & _
" received on: " & oMail.ReceivedTime
End If
Next
Next
strMsg = "There are " & AttCount & " attachments in the " & olSel.count & " selected emails."
nRes = MsgBox(strMsg, vbOKOnly + vbInformation, "Count Attachments")
End Sub
Function IsEmbedded(Att As Attachment) As Boolean
Dim PropAccessor As PropertyAccessor
Set PropAccessor = Att.PropertyAccessor
IsEmbedded = (PropAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001F") <> "")
End Function
You would need to actually look at the HTML body and check if any image referes to the attachment, either through the cid attribute (<img src="cid:xyz">) or through the file name or url. You'd also need to look at the PR_ATTACH_HIDDEN MAPI property.
If using Redemption (I am its author) is an option, it exposes RDOAttachment.Hidden property:
Set Session = CreateObject("Redemption.RDOSession")
Session.MAPIOBJECT = Application.Session.MAPIOBJECT
for each msg in Application.ActiveExplorer.Selection
set rMsg = Session.GetRDOObjectFromOutlookObject(msg)
Debug.Print "-------- " & msg.Subject
for each attach in rMsg.Attachments
Debug.Print attach.Hidden & " - " & attach.FileName
next
next
In the code below I don’t understand how the subroutine checks if the emails coming through are a reply of an email previously sent.
The first subroutine seems to check if the subject line of an incoming email matches this condition: "re: " & strSubject Or InStr(LCase(Item.Subject), strSubject)
After that I am confused. The only way the code works for me is by using categories. It does not work as shown below.
Public WithEvents objInboxItems As Outlook.Items
Private Sub Application_Startup()
Set objInboxItems = Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
'If receive the reply, clear the flag and remove the reminder
Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
Dim objSentItems As Outlook.Items
Dim objVariant As Variant
Dim i As Long
Dim strSubject As String
Dim dSendTime As String
Set objSentItems = Outlook.Application.Session.GetDefaultFolder(olFolderSentMail).Items
If Item.Class = olMail Then
For i = 1 To objSentItems.Count
If objSentItems.Item(i).Class = olMail And **objSentItems.Item(i).categories = "Not Completed"** Then
Set objVariant = objSentItems.Item(i)
strSubject = LCase(objVariant.Subject)
dSendTime = objVariant.SentOn
If LCase(Item.Subject) = "re: " & strSubject Or InStr(LCase(Item.Subject), strSubject) > 0 Then
If Item.SentOn > dSendTime Then
With objVariant
.ClearTaskFlag
.ReminderSet = False
.Save
End With
End If
End If
End If
Next i
End If
End Sub
'Get a prompt asking if to send a notification email
Private Sub Application_Reminder(ByVal Item As Object)
Dim strPrompt As String
Dim nResponse As Integer
Dim objFollowUpMail As Outlook.MailItem
'You can change the subject as per your real case
If (Item.Class = olMail) And (LCase(Item.Subject) = "datanumen outlook repair") Then
strPrompt = "You haven't yet recieved the reply of " & Chr(34) & Item.Subject & Chr(34) & " within your expected time. Do you want to send a follow-up notification email?"
nResponse = MsgBox(strPrompt, vbYesNo + vbQuestion, "Confirm to Send a Follow-Up Notification Email")
If nResponse = vbYes Then
Set objFollowUpMail = Application.CreateItem(olMailItem)
With objFollowUpMail
.To = Item.Recipients.Item(1).Address
.Subject = "Follow Up: " & Chr(34) & Item.Subject & Chr(34)
.Body = "Please respond to my email " & Chr(34) & Item.Subject & Chr(34) & "as soon as possible"
.attachments.Add Item
.Display
End With
End If
End If
End Sub
The code just needs better commenting. The basic logic is: When a new email comes in, check if it's a reply to any email in the sent box. If so, remove the task and reminder flags from the sent email.
Public WithEvents objInboxItems As Outlook.Items
Private Sub Application_Startup()
Set objInboxItems = Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
'If receive the reply, clear the flag and remove the reminder
Private Sub objInboxItems_ItemAdd(ByVal Item As Object) 'New item received in inbox
Dim objSentItems As Outlook.Items
Dim objVariant As Variant
Dim i As Long
Dim strSubject As String
Dim dSendTime As String
' get all emails in sent box
Set objSentItems = Outlook.Application.Session.GetDefaultFolder(olFolderSentMail).Items
If Item.Class = olMail Then 'if new inbox item is email
For i = 1 To objSentItems.Count 'for each item in sent box
If objSentItems.Item(i).Class = olMail Then ' if sent item is email
Set objVariant = objSentItems.Item(i) 'sent email
strSubject = LCase(objVariant.Subject) 'sent email subject
dSendTime = objVariant.SentOn 'sent email send date
'Check subject, if new email is reply to sent email, or new email subject contains sent email subject
If LCase(Item.Subject) = "re: " & strSubject Or InStr(LCase(Item.Subject), strSubject) > 0 Then
If Item.SentOn > dSendTime Then ' if new email has later send date then sent email (else can't be reply)
With objVariant 'with sent email
.ClearTaskFlag ' clear flag
.ReminderSet = False 'remove reminder
.Save
End With
End If
End If
End If
Next i
End If
End Sub
The code listed above is badly written and wrong in general. The ItemAdd event is fired when an item is added to the folder, not received. For example, a user may move some items from one folder to another triggering this event. If you want to handle all incoming emails you need to handle the NewMailEx event of the Application class which is fired when a new message arrives in the Inbox and before client rule processing occurs. You can use the Entry ID returned in the EntryIDCollection array to call the NameSpace.GetItemFromID method and process the item. This event fires once for every received item that is processed by Microsoft Outlook. The item can be one of several different item types, for example, MailItem, MeetingItem, or SharingItem. The EntryIDsCollection string contains the Entry ID that corresponds to that item.
For i = 1 To objSentItems.Count 'for each item in sent box
If objSentItems.Item(i).Class = olMail Then ' if sent item is email
Instead of interating over all items in the folder and finding items that correspond to your conditions I'd recommend using the Find/FindNext or Restrict methods of the Items class. Read more about these methods in the following articles:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
I tried to recreate the situation, given flags are not reliable in my setup.
It may be possible to remove reminders by reinitializing ReminderTime.
Code for ThisOutlookSession
Option Explicit
Public WithEvents objInboxItems As Items
Private Sub Application_Startup()
Set objInboxItems = Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub test_objInboxItems_ItemAdd()
' For testing select a reply to the flagged sent item
objInboxItems_ItemAdd ActiveExplorer.Selection(1)
End Sub
Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
' If reply received,
' clear the flag and remove the reminder from the corresponding sent item
' No attempt to make the logic efficient
' - Find / Restrict in the sent items folder
' In my setup
' - TaskDueDate is always 4501-01-01 (no date)
' - Reminders on mailitems are not functional
Dim objSentItems As Items
Dim objVariant As Variant
Dim i As Long
Dim strSubject As String
Set objSentItems = Session.GetDefaultFolder(olFolderSentMail).Items
If Item.Class = olmail Then
Debug.Print
Debug.Print "Item.Subject ...........: " & Item.Subject
For i = 1 To objSentItems.Count
If objSentItems.Item(i).Class = olmail Then
Set objVariant = objSentItems.Item(i)
strSubject = LCase(objVariant.Subject)
If objVariant.ReminderTime <> "4501-01-01" Then
Debug.Print " strSubject ............: " & strSubject
Debug.Print " objVariant.SentOn .....: " & objVariant.SentOn
Debug.Print " objVariant.ReminderTime: " & objVariant.ReminderTime
If LCase(Item.Subject) = "re: " & strSubject Or InStr(LCase(Item.Subject), strSubject) > 0 Then
'Debug.Print " Item.SentOn .....: " & Item.SentOn
'Debug.Print " objVariant.SentOn: " & objVariant.SentOn
If Item.SentOn > objVariant.SentOn Then
Debug.Print " * strSubject ......: " & strSubject
Debug.Print " * Item.SentOn .....: " & Item.SentOn
Debug.Print " * objVariant.SentOn: " & objVariant.SentOn
If Now > objVariant.ReminderTime Then
With objVariant
' remove flag
.ClearTaskFlag
' attempt to remove reminder
.ReminderSet = False
' reinitializing ReminderTime may have an impact
.ReminderTime = "4501-01-01"
.Save
Debug.Print " ** Flag removed."
Debug.Print " ** Reminder removal attempted."
End With
End If
End If
Else
Debug.Print " *** subject does not match"
End If
End If
End If
Next i
End If
Debug.Print "done"
End Sub
Private Sub test_ToggleMarkAsTaskFlagAndSetReminder()
' for testing
' select a mailitem in the sent items folder to add a flag and a reminder
ToggleMarkAsTaskFlagAndSetReminder ActiveExplorer.Selection(1)
End Sub
Private Sub ToggleMarkAsTaskFlagAndSetReminder(ByVal objItem As Object)
' In my setup
' - TaskDueDate is always 4501-01-01 (no date)
' - Reminders on mailitems are not functional
If TypeOf objItem Is MailItem Then
Debug.Print
Debug.Print "objItem.Subject .............: " & objItem.Subject
Debug.Print " objItem.TaskDueDate Current: " & objItem.TaskDueDate
Debug.Print " objItem.ReminderTime Current: " & objItem.ReminderTime
' https://learn.microsoft.com/en-us/office/vba/api/outlook.olmarkinterval
If objItem.IsMarkedAsTask = False Then
objItem.MarkAsTask (olMarkThisWeek)
Debug.Print " * Marked as task"
' In my setup - TaskDueDate is always 4501-01-01
Debug.Print " objItem.TaskDueDate Updated?: " & objItem.TaskDueDate
Debug.Print " objItem.ReminderTime Updated?: " & objItem.ReminderTime
' In my setup - Reminders on mailitems are not functional
Debug.Print " objItem.ReminderSet Current: " & objItem.ReminderSet
objItem.ReminderSet = True
Debug.Print " objItem.ReminderSet Updated: " & objItem.ReminderSet
objItem.ReminderTime = DateAdd("d", -7, Now) ' testing
Debug.Print " objItem.ReminderTime Updated: " & objItem.ReminderTime
Else 'Reinitialize item
objItem.ClearTaskFlag
Debug.Print " * Task cleared"
' TaskDueDate not functional in my setup, remains 4501-01-01
Debug.Print " objItem.TaskDueDate Updated?: " & objItem.TaskDueDate
objItem.ReminderSet = False
Debug.Print " objItem.ReminderSet = False"
objItem.ReminderTime = "4501-01-01"
Debug.Print " objItem.ReminderTime Updated: " & objItem.ReminderTime
End If
'objItem.Display
objItem.Save
Else
Debug.Print "not a mailitem"
End If
End Sub
I need to move the incoming message to the related folder depending on a key in the subject of the message.
I developed a script for getting the key in the subject of new message. How can I search rest of messages by a key and retrieve related folder?
Sub CustomMailMessageRule(Item As Outlook.MailItem)
Dim strTicket, strSubject As String
Dim strFolder As String
strTicket = "None"
strSubject = Item.Subject
If InStr(1, strSubject, "#-") > 0 Then
strSubject = Mid(strSubject, InStr(strSubject, "#-") + 2)
If InStr(strSubject, " ") > 0 Then
strTicket = Left(strSubject, InStr(strSubject, " ") - 1)
End If
End If
the unknown part, search all folders by key and retrieve the related folder
strFolder = "???"
and finally, move the incoming message to the related folder by below code
If InStr(strFolder) > 0 Then
Item.Move Session.GetDefaultFolder(olFolderInbox).folders(strFolder)
MsgBox "Your New Message has been moved to related folder "
End Sub
I'm new in VBA.
This searches folders recursively for an item by subject.
Option Explicit
Sub CustomMailMessageRule(Item As mailItem)
Dim strSubject As String
Dim strDynamic As String
Dim strFilter As String
Dim originFolder As Folder
Dim startFolder As Folder
Dim uPrompt As String
strSubject = Item.subject
Set startFolder = Session.GetDefaultFolder(olFolderInbox)
' To reference any inbox not specifically the default inbox
'Set startFolder = Session.folders("email address").folders("Inbox")
Set originFolder = startFolder
' For testing the mail subject is "This is a test"
If InStr(1, strSubject, "This is") > 0 Then
' For testing the dynamically determined key is "a test"
strDynamic = "a test"
strFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " LIKE '%" & strDynamic & "%'"
Debug.Print strFilter
' Advanced search requires "Scope" to be specified so it appears
' not easy/possible to process every subfolder in the way described here
' https://stackoverflow.com/questions/43638711/outlook-macro-advanced-search
' This recursively processes every subfolder
processFolder originFolder, startFolder, strFilter, Item
uPrompt = "Mail with " & strDynamic & " in subject not found in subfolders of " & startFolder.Name
Debug.Print uPrompt
MsgBox uPrompt
End If
ExitRoutine:
Set startFolder = Nothing
End Sub
Private Sub processFolder(ByVal originFolder As Folder, ByVal oParent As Folder, strFilter As String, oIncomingMail As mailItem)
Dim oFolder As Folder
Dim oObj As Object
Dim filteredItems As items
Dim uResp As VbMsgBoxResult
Debug.Print oParent
If originFolder.EntryID <> oParent.EntryID Then
' This narrows the search.
' https://stackoverflow.com/questions/21549938/vba-search-in-outlook
Set filteredItems = oParent.items.Restrict(strFilter)
If filteredItems.count > 0 Then
Debug.Print oParent
Debug.Print "Mail found in " & oParent.Name
uResp = MsgBox(Prompt:="Move Message to folder: " & oParent.Name & "?", _
Buttons:=vbYesNoCancel)
If uResp = vbYes Then
oIncomingMail.move oParent
End
End If
If uResp = vbCancel Then End
End If
End If
If (oParent.folders.count > 0) Then
For Each oFolder In oParent.folders
processFolder originFolder, oFolder, strFilter, oIncomingMail
Next
End If
End Sub
I have created a macro in Outlook VBA below that replies with the sender first name added to the greeting, adds some text for the body, and adds a signature in the fonts I want.
What I need help with is getting the macro to pull ALL of the names of the senders, assigning a value to them that I can then place elsewhere in the body of the email. If that cannot be done, I would settle for just getting all of the names into the greeting, though it is much preferred to be able to move the names around.
Example: sender was Name1;Name2
Currently, this macro will pull only Name1 (giving "Dear Name1,"), but
I would like to get to "Dear Name1 and Name2," at the very least.
Best would be able to have Name1 be in the greeting, then Name2 is placed in the body of the text.
I believe I have taken this as far as I can on my own and now turn to you experts for assistance! Thank you!!
Sub AutoAddGreetingtoReply()
Dim oMail As MailItem
Dim oReply As MailItem
Dim GreetTime As String
Dim strbody As String
Dim SigString As String
Dim Signature As String
Dim R As Outlook.Recipient
Dim strGreetName As String
Select Case Application.ActiveWindow.Class
Case olInspector
Set oMail = ActiveInspector.CurrentItem
Case olExplorer
Set oMail = ActiveExplorer.Selection.Item(1)
End Select
strbody = "<H3><B></B></H3>" & _
"<br><br><B></B>" & _
"Please visit this website to view your transactions.<br>" & _
"Let me know if you have problems.<br>" & _
"Questions" & _
"<br><br>Thank you"
SigString = Environ("appdata") & _
"\Microsoft\Signatures\90 Days.htm"
On Error Resume Next
If Dir(SigString) <> "" Then
strGreetName = Left$(oMail.SenderName, InStr(1, oMail.SenderName, " ") - 1)
End If
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
Set oReply = oMail.ReplyAll
With oReply
.CC = ""
.HTMLBody = "<Font Face=calibri>Dear " & strGreetName & "," & R1 & strbody & "<br>" & Signature
.Display
End With
End Sub
Given a string "First Last" then get the right side of the string like this
sndrName = oMail.SenderName
lastName = right(sndrName, len(sndrName) - InStr(1, sndrName, " "))
Using the format in your code:
strGreetName = Left$(oMail.SenderName, InStr(1, oMail.SenderName, " ") - 1)
lastName = right(oMail.SenderName, len(oMail.SenderName) - InStr(1, oMail.SenderName, " "))
If there is a space in the text InStr returns the position. https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/instr-function
Original mail has one sender. A ReplyAll has recipients, including the original mail sender.
Option Explicit
Private Sub ReplyFirstNames()
Dim oMail As mailitem
Dim oReply As mailitem
Dim strGreetName As String
Dim strGreetNameAll As String
Dim i As Long
Select Case Application.ActiveWindow.Class
Case olInspector
Set oMail = ActiveInspector.currentItem
Case olExplorer
Set oMail = ActiveExplorer.Selection.Item(1)
End Select
Set oReply = oMail.ReplyAll
With oReply
Debug.Print "The reply all recipients are:"
For i = 1 To .Recipients.count
Debug.Print .Recipients(i)
' Given the format First Last
strGreetName = Left(.Recipients(i), InStr(1, .Recipients(i), " ") - 1)
strGreetNameAll = strGreetNameAll & strGreetName & ", "
Next i
Debug.Print strGreetNameAll
' remove extra comma and space from end
strGreetNameAll = Left(strGreetNameAll, Len(strGreetNameAll) - 2)
Debug.Print strGreetNameAll
.htmlbody = "<Font Face=calibri>" & strGreetNameAll & .htmlbody
.Display
End With
End Sub