Outlook VBA GetDirectReports infomation

[pavin]

Dear Techies,

I'm looking for a VBA code to get the direct reporties for a contact using their email ID's. I used the following code which works fine for few, But not for ALL. Not sure why its failing. Request help.

Sub GetOtlkDtls()
Dim EmailId As String
    For k = 1 To Sheets.Count
        If Sheets(k).name = "OutPut" Then
        Application.DisplayAlerts = False
            Sheets(k).Delete
        Application.DisplayAlerts = True
        End If
    Next
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.name = "OutPut"
    [A1].Value = "SUPERVISOR"
    [B1].Value = "REPORTEE NAME"
    [C1].Value = "DESIGNATION"
    [D1].Value = "EMAIL"
    Columns.AutoFit
    
For j = 2 To Sheets("Main").[A1048576].End(xlUp).Row
    EmailId = Sheets("Main").Range("A" & j).Value
    If EmailId = "" Then Exit Sub
    Call Emp_Email(EmailId)
Next
    Sheets("OutPut").Columns.AutoFit
End Sub
 

Private Sub Emp_Email(EmId As String)
On Error Resume Next
Dim asdf As Variant
Dim myOL As Outlook.Application, outApp As Outlook.Application
Dim myMail As Outlook.MailItem
Dim myAEs As Outlook.ExchangeDistributionList
Dim myAE As Outlook.AddressEntry ' or object
Dim i As Integer, j As Integer, k As Integer, AliasNm As String, asdsdf As String, maxcount As Integer, a As Integer
Dim myReci As Outlook.Recipient
Dim myTest As Outlook.AddressList

Dim outTI As Object 'TaskItem
Dim outRec As Object 'Recipient
Dim outAL As Object 'AddressList

    Set outApp = GetObject(, "Outlook.Application")
    Set outAL = outApp.Session.AddressLists.Item("Global Address List")
    Set outTI = outApp.CreateItem(3)
    outTI.Assign
       
    Sheets("OutPut").Select
        AliasNm = EmId 'Cells(1, i)
        Set outRec = outTI.Recipients.Add(AliasNm)
        outRec.Resolve
        Dim exitloop As Boolean
        Set myReci = Outlook.Application.Session.CreateRecipient(outRec.AddressEntry.name)
        Debug.Print myReci.AddressEntry.GetExchangeUser
        DoEvents
        Dim oExUser As Outlook.ExchangeUser
        Set oExUser = myReci.AddressEntry.GetExchangeUser
        asdsdf = oExUser.GetDirectReports.GetFirst
        
        If asdsdf <> "" And Not IsEmpty(asdsdf) Then
        maxcount = oExUser.GetDirectReports.Count
        'Debug.Print oExUser.GetDirectReports.GetLast
        
        For a = 1 To maxcount
            Cells([A1048576].End(xlUp).Offset(1, 0).Row, 1).Value = myReci
            Cells([A1048576].End(xlUp).Offset(0, 0).Row, 2).Value = oExUser.GetDirectReports.Item(a).name
            Cells([A1048576].End(xlUp).Offset(0, 0).Row, 3).Value = oExUser.GetDirectReports.Item(a).GetExchangeUser.JobTitle
            Cells([A1048576].End(xlUp).Offset(0, 0).Row, 4).Value = oExUser.GetDirectReports.Item(a).GetExchangeUser.PrimarySmtpAddress
        Next
        
        End If
        Application.StatusBar = j
        maxcount = 0
       Set oExUser = Nothing
End Sub