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

최종 하위 별도의 모듈

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