Auto open incoming mail from internal email address - vba

Question

I'm trying to auto open incoming mails from a specific address.
Found code online which works if I send from Gmail but not from my domain.
Public WithEvents objInbox As Outlook.Folder
Public WithEvents objInboxItems As Outlook.Items
Private Sub Application_Startup()
Set objInbox = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
Set objInboxItems = objInbox.Items
End Sub
'Occurs when incoming emails arrive in Inbox
Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
Dim objMail As Outlook.MailItem
Dim strSenders As String
Dim varSenders As Variant
Dim i As Long
If TypeOf Item Is MailItem Then
Set objMail = Item
'Change the specific persons
strSenders = "addr#Mydomain.com;addr#ExDomain.com"
varSenders = Split(strSenders, ";")
'Open the emails from specific persons
For i = 0 To UBound(varSenders)
If objMail.SenderEmailAddress = varSenders(i) Then
objMail.Display
Exit For
End If
Next
End If
End Sub
This question has been asked
HERE. The solution didn't work.
Could it be premmisions? GPO? Is there an alternative?

Answer 1

Your script expects an SMTP address, but internal emails use EX type addresses. You need to use MailItem.Sender.GetExchangeUser.PrimarySmtpAddress for the EX type senders.
Modify your script as follows (off the top of my head):
Dim senderAddress As String
if objMail.SenderEmailType = "SMTP" Then senderAddress = objMail.SenderEmailAddress
ElseIf objMail.SenderEmailType = "EX" Then senderAddress = objMail.Sender.GetExchangeUser.PrimarySmtpAddress
Else senderAddress = ""
For i = 0 To UBound(varSenders)
If senderAddress = varSenders(i) Then
objMail.Display
Exit For
End If
Next