Get email addresses of a list of users using outllook

[Tejas Kore]

Hello Friends,

I am trying get email addresses of a list of users present in Sheet1:C. User's names are like: "FirstName LastName" eg. John Smith.

First iteration completes but 2nd iteration giving error. Please find the error screenshot attached.

Following is my VBA code:

Sub Fetch_Emailaddress()
  

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim i As Integer
    Dim lrow_A As Integer

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet1")

    lrow_A = ws.Range("A" & Rows.Count).End(xlUp).Row
   
    Dim oout As Object
    'Dim oout As Outlook.Application
    Dim ns As Namespace
    Dim flag As Boolean
    Dim to_get_emailaddress_Addr As Variant
    Dim to_get_emailaddress_ExUser As Variant
   
    Set oout = CreateObject("Outlook.Application")
    Set ns = oout.GetNamespace("MAPI")
   
    For i = 2 To lrow_A
        flag = True
        Set to_get_emailaddress = ns.CreateRecipient(ws.Cells(i, 3))
        to_get_emailaddress.Resolve
'        ws.Cells(i, 4) = to_get_emailaddress.AddressEntry.GetExchangeUser.PrimarySmtpAddress
        'Debug.Print to_get_emailaddress.AddressEntry
        Set to_get_emailaddress_Addr = to_get_emailaddress.AddressEntry
        Debug.Print i
        Debug.Print to_get_emailaddress_Addr.Type --> Getting run time error here
'        If to_get_emailaddress_Addr Is Nothing Then
'            flag = False
'        Else
'            ws.Cells(i, 4) = to_get_emailaddress_Addr.GetExchangeUser.PrimarySmtpAddress
'        End If
        'MsgBox to_get_jobtitle_ExUser.JobTitle
'        If flag Then
'            Cells(i, 4) = to_get_emailaddress_ExUser.PrimarySmtpAddress
'        End If
'        Set to_get_emailaddress = Nothing
'        Set to_get_emailaddress_Addr = Nothing

    Next i
End Sub

Getting error here -->

Any help would be appreciated.

Thanks !!

 

[Tejas Kore]

Hello Friends,

I am trying get email addresses of a list of users present in Sheet1:C. User's names are like: "FirstName LastName" eg. John Smith.

First iteration completes but 2nd iteration giving error. Please find the error screenshot attached.

Following is my VBA code:

Sub Fetch_Emailaddress()
 

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim i As Integer
    Dim lrow_A As Integer

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet1")

    lrow_A = ws.Range("A" & Rows.Count).End(xlUp).Row
  
    Dim oout As Object
    'Dim oout As Outlook.Application
    Dim ns As Namespace
    Dim flag As Boolean
    Dim to_get_emailaddress_Addr As Variant
    Dim to_get_emailaddress_ExUser As Variant
  
    Set oout = CreateObject("Outlook.Application")
    Set ns = oout.GetNamespace("MAPI")
  
    For i = 2 To lrow_A
        flag = True
        Set to_get_emailaddress = ns.CreateRecipient(ws.Cells(i, 3))
        to_get_emailaddress.Resolve
'        ws.Cells(i, 4) = to_get_emailaddress.AddressEntry.GetExchangeUser.PrimarySmtpAddress
        'Debug.Print to_get_emailaddress.AddressEntry
        Set to_get_emailaddress_Addr = to_get_emailaddress.AddressEntry
        Debug.Print i
        Debug.Print to_get_emailaddress_Addr.Type --> Getting run time error here
'        If to_get_emailaddress_Addr Is Nothing Then
'            flag = False
'        Else
'            ws.Cells(i, 4) = to_get_emailaddress_Addr.GetExchangeUser.PrimarySmtpAddress
'        End If
        'MsgBox to_get_jobtitle_ExUser.JobTitle
'        If flag Then
'            Cells(i, 4) = to_get_emailaddress_ExUser.PrimarySmtpAddress
'        End If
'        Set to_get_emailaddress = Nothing
'        Set to_get_emailaddress_Addr = Nothing

    Next i
End Sub

Getting error here -->

Any help would be appreciated.

Thanks !!

Apologies for the inconvenience. There were few names which were not able to resolve or had multiple entries in the addresslist hence it was giving runtime error. I added "On error Resume Next" to avoid the error.