fetching only specific outlook email addresses with inputed cell value email domain-CodePudding

So apparently I am fetching outlook emails from my outlook account
I was able to fetch all email addresses and now i am trying to fetch only specific email address from inbox eg. Gmail.com that returns only gmail addresses only.
I modified the code where i used array to store the addresses temporarily and then compare to string . but after altering the code it returns nothing (not even errors). PS. I am a beginner in VBA.

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 mails will be problematic as i want to make sure i dont expose any mail domains other than the defined ones .

CodePudding user response：

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