VBAからGALの電子メール送信者の詳細を取得する

Question

フォルダーから電子メールの送信者の詳細（名前、役職、部署など）を取得しようとしています。私は私のアドレス帳のconactsのための必要な詳細を得ることができますが、私はGALの連絡先の詳細を取得していません。

私のコードは以下の通りです：

Public Sub DisplaySenderDetails() 
Dim Sender As Outlook.AddressEntry 
Dim xlApp As Object 
Dim xlWB As Object 
Dim xlSheet As Object 
Dim rCount As Long 
Dim bXStarted As Boolean 
Dim enviro As String 
Dim strPath As String 
Dim strColB, strColC, strColD, strColE, strColF, strColG As String 
Dim objOL As Outlook.Application 
Dim objItems As Outlook.Items 
Dim objFolder As Outlook.MAPIFolder 
Dim obj As Object 
Dim objNS As Outlook.NameSpace 
Dim olItem As Outlook.MailItem 
Dim strdate As String 
Dim oExUser As Outlook.ExchangeUser 
Dim olGAL As Outlook.AddressList 
Dim olEntry As Outlook.AddressEntries 



' Get Excel set up 
    enviro = CStr(Environ("USERPROFILE")) 
     'the path of the workbook 
    strPath = enviro & "\Documents\test2.xlsx" 
    On Error Resume Next 
    Set xlApp = GetObject(, "Excel.Application") 
    If Err <> 0 Then 
     Application.StatusBar = "Please wait while Excel source is opened ... " 
     Set xlApp = CreateObject("Excel.Application") 
     bXStarted = True 
    End If 
    On Error GoTo 0 
    'Open the workbook to input the data 
     Set xlWB = xlApp.Workbooks.Open(strPath) 
     Set xlSheet = xlWB.Sheets("Sheet1") 



    Set objNS = GetNamespace("MAPI") 
    Set olGAL = objNS.GetGlobalAddressList() 
    Set objFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("Abc") 
    Set objItems = objFolder.Items 
    Set olEntry = olGAL.AddressEntries 

    For Each obj In objItems 

    With obj 

    Set Sender = obj.Sender 
    Set olItem = obj 

    If TypeName(obj) = "MailItem" Then 

    On Error Resume Next 

    Dim i As Long 
    For i = 1 To olEntry.Count 

    If olEntry.Item.Address = Sender.Address Then 


     Set oExUser = Sender.GetExchangeUser 
     rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row 
     rCount = rCount + 1 

     strdate = DateValue(olItem.ReceivedTime) 
     If strdate >= #7/1/2016# Then 
      strColB = Sender.Name 
      strColC = oExUser.JobTitle 
      strColD = oExUser.Department 
      strColE = oExUser.PrimarySmtpAddress 
      strColF = olItem.Subject 
      strColG = olItem.ReceivedTime 


      xlSheet.Range("B" & rCount) = strColB 
      xlSheet.Range("C" & rCount) = strColC 
      xlSheet.Range("D" & rCount) = strColD 
      xlSheet.Range("E" & rCount) = strColE 
      xlSheet.Range("F" & rCount) = strColF 
      xlSheet.Range("G" & rCount) = strColG 

      strColB = "" 
      strColC = "" 
      strColD = "" 
      strColE = "" 
      strColF = "" 
      trColG = "" 
     Else 
      Exit For 
     End If 
    End If 
    Next i 
End If 

End With 
Next 

Set obj = Nothing 
Set objItems = Nothing 
Set objFolder = Nothing 
Set objOL = Nothing 

私は次の関数を使用しています

Answer 1

End Subの独立したモジュールで

Private Function getSmtpMailAddress(sMail As Outlook.mailItem) As String 
    Dim strAddress As String 
    Dim strEntryId As String 
    Dim objRecipient As Outlook.Recipient 
    Dim objSession As Outlook.NameSpace 
    Dim objAddressentry As Outlook.AddressEntry 
    Dim objExchangeUser As Outlook.ExchangeUser 
    Dim objReply As Outlook.mailItem 

    On Error GoTo ErrHandler 

    If sMail.SenderEmailType = "SMTP" Then 
     strAddress = sMail.SenderEmailAddress 
    Else 
     Set objReply = sMail.reply() 
     Set objRecipient = objReply.recipients.item(1) 

     strEntryId = objRecipient.EntryID 

     objReply.Close OlInspectorClose.olDiscard 

     Set objSession = getMapiSession 

     strEntryId = objRecipient.EntryID 

     Set objAddressentry = objSession.GetAddressEntryFromID(strEntryId) 
     Set objExchangeUser = objAddressentry.GetExchangeUser() 

     strAddress = objExchangeUser.PrimarySmtpAddress() 
    End If 

    getSmtpMailAddress = strAddress 

    Exit Function 

ErrHandler: 
    Err.Clear 
    On Error GoTo 0 
    getSmtpMailAddress = "???" 
End Function 

ヘルパールーチン：

Private objNameSpace As NameSpace 

Private Sub logonMapiSession() 
    Set objNameSpace = Application.GetNamespace("MAPI") 

    objNameSpace.Logon Profile:="", Password:="", ShowDialog:=False, NewSession:=False 
End Sub 

Public Sub logoffMapiSession() 
    If Not (objNameSpace Is Nothing) Then 
     objNameSpace.Logoff 

     Set objNameSpace = Nothing 
    End If 
End Sub 

Public Function getMapiSession() As NameSpace 
    If objNameSpace Is Nothing Then 
     logonMapiSession 
    End If 

    Set getMapiSession = objNameSpace 
End Function