Fetching email addresses with email domain cell value

Question

I fetch email addresses from my Outlook account.

Now I am trying to fetch only specific email address from inbox e.g. Gmail.com that returns gmail addresses only.

I modified the code where I used array to store the addresses temporarily and then compare to string. After altering the code it returns nothing (not even errors).

Option Explicit

Sub GetInboxItems()

Dim ol As outlook.Application
Dim ns As outlook.Namespace
Dim fol As outlook.Folder
Dim I As Object
Dim mi As outlook.MailItem
Dim N As Long
Dim val As String
Dim MyArray() As String, MyString As String, J As Variant, K As Integer

Dim MyAs As Variant
Dim Awo As Variant

MyString = Worksheets("Inbox").Range("D1")
MyArray = Split(MyString, ";")

Application.ScreenUpdating = False
Set ol = New outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.GetDefaultFolder(olFolderInbox)

'Dim inputSheet As Worksheet
'Dim aCellOnInputSheet As Range
'Dim inputDateCell As Range
'Dim userSheetName As String

'Set cod = ThisWorkbook.Worksheets("Inbox")
'Set aCellOnInputSheet = cod.Range("D1")
'userSheetName = aCellOnInputSheet.Value

Range("A3", Range("A3").End(xlDown).End(xlToRight)).Clear

N = 2
For Each I In fol.Items
    If I.Class = olMail Then
        Set mi = I
        
        N = N + 1
        If mi.SenderEmailType = "EX" Then
        
            MyAs = Array(mi.Sender.GetExchangeUser().PrimarySmtpAddress)
        
            For Each Awo In MyAs
                If InStr(MyString, Awo) > 0 Then
                    Cells(N, 1).Value = mi.Sender.GetExchangeUser().PrimarySmtpAddress             
                    Cells(N, 2).Value = mi.SenderName
                    Exit For
                End If
            Next
        '    Cells(N, 1).Value = mi.Sender.GetExchangeUser().PrimarySmtpAddress  
        '   Cells(N, 2).Value = mi.SenderName
                  
        Else
            MyAs = Array(mi.SenderEmailAddress)
                       
            For Each Awo In MyAs
                If InStr(MyString, Awo) > 0 Then          
                    Cells(N, 1).Value = mi.SenderEmailAddress
                    Cells(N, 2).Value = mi.SenderName 
                    Exit For
                End If
            Next   
        End If
    End If
Next I

Application.ScreenUpdating = True
End Sub

Fetching all email addresses will be problematic. I don't want to expose any email domains other than the defined ones.

Answer 1

Minimal changes to manipulating the row n and switching the variables in Instr should be sufficient.

This also shows how to drop the array if one domain.

Option Explicit

Sub GetInboxItems_SingleDomain()

' Early binding - reference to Microsoft Outlook XX.X Object Library required
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim fol As Outlook.Folder

Dim folItm As Object
Dim mi As Outlook.MailItem
Dim n As Long

Dim myString As String
Dim myAddress As String

myString = Worksheets("Inbox").Range("D1")  ' gmail.com
'Debug.Print myString

Application.ScreenUpdating = False

Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.GetDefaultFolder(olFolderInbox)

Range("A3", Range("A3").End(xlDown).End(xlToRight)).Clear

n = 3

' If slow, limit the number of items in the loop
' e.g. https://stackoverflow.com/questions/21549938/vba-search-in-outlook
' strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:fromemail" & Chr(34) & " like '%" & myString & "'"

For Each folItm In fol.Items

    If folItm.Class = olMail Then
    
        Set mi = folItm
        
        If mi.SenderEmailType = "EX" Then
            myAddress = mi.Sender.GetExchangeUser().PrimarySmtpAddress
        Else
            myAddress = mi.SenderEmailAddress
        End If
        'Debug.Print myAddress
        
        'The bigger text on the left
        ' In general, not necessarily here, keep in mind case sensitivity
        If InStr(LCase(myAddress), LCase(myString)) > 0 Then
            Cells(n, 1).Value = myAddress
            Cells(n, 2).Value = mi.SenderName
            n = n + 1
        End If
        
    End If
    
Next folItm

Application.ScreenUpdating = True

Debug.Print "Done."

End Sub