Excel의 연락처 목록에서 전자 메일 아이디로 이름 가져 오기

Question

전자 메일 ID 목록이 Excel 시트에 있는데 VBA 스크립트를 사용하여 Outlook 연락처 목록에서 이름을 가져 오려고합니다. 온라인으로 검색했지만 나에게 효과가있는 것을 찾지 못했습니까?

어떻게 수행 할 수 있습니까?

Answer 1

다음은입니다. 아래 코드는 "abc@xyz.com"에 해당하는 이름을 가져옵니다. 배열을 사용하여 비교할 수 있습니다. 더 좋은 방법이 있는지 확실하지 않습니다.

Public Sub getName() 
    Dim contact As Object 
    Dim AL As Object 
    Dim outApp As Object 
    Set outApp = CreateObject("Outlook.Application") 
    'Logon 
    outApp.Session.Logon 

    'Get contact from Outlook 
    Set AL = outApp.Session.GetDefaultFolder(10) 
     For Each contact In AL.Items 
      'iterate through each contact and compare 
      If contact.Email1Address = "abc@xyz.com" Then 
       Debug.Print (contact.FullName) 
      End If 
     Next contact 
    outApp.Session.Logoff 
    outApp.Quit 

    'cleanup 
    Set outApp = Nothing 
    Set GAL = Nothing 
End Sub 

Answer 2

아래 코드가 도움이 될 수 있습니까? My Name <My.Name@MyCompany.co.uk>, My Name, MyName@Gmail.Com

Sub Test() 

    Dim rEmails As Range 
    Dim rEmail As Range 
    Dim oOL As Object 

    Set oOL = CreateObject("Outlook.Application") 
    Set rEmails = Sheet1.Range("A1:A3") 

    For Each rEmail In rEmails 
     rEmail.Offset(, 1) = ResolveDisplayNameToSMTP(rEmail.Value, oOL) 
    Next rEmail 

End Sub 

' Author: Sue Mosher - updated by D.Bartrup-Cook to work in Excel late binding. 
Public Function ResolveDisplayNameToSMTP(sFromName, OLApp As Object) As String 


    Select Case Val(OLApp.Version) 
     Case 11 'Outlook 2003 

      Dim oSess As Object 
      Dim oCon As Object 
      Dim sKey As String 
      Dim sRet As String 

      Set oCon = OLApp.CreateItem(2) 'olContactItem 

      Set oSess = OLApp.GetNameSpace("MAPI") 
      oSess.Logon "", "", False, False 
      oCon.Email1Address = sFromName 
      sKey = "_" & Replace(Rnd * 100000 & Format(Now, "DDMMYYYYHmmss"), ".", "") 
      oCon.FullName = sKey 
      oCon.Save 

      sRet = Trim(Replace(Replace(Replace(oCon.email1displayname, "(", ""), ")", ""), sKey, "")) 
      oCon.Delete 
      Set oCon = Nothing 

      Set oCon = oSess.GetDefaultFolder(3).Items.Find("[Subject]=" & sKey) '3 = 'olFolderDeletedItems 
      If Not oCon Is Nothing Then oCon.Delete 

      ResolveDisplayNameToSMTP = sRet 

     Case 14 'Outlook 2010 

      Dim oRecip As Object 'Outlook.Recipient 
      Dim oEU As Object 'Outlook.ExchangeUser 
      Dim oEDL As Object 'Outlook.ExchangeDistributionList 

      Set oRecip = OLApp.Session.CreateRecipient(sFromName) 
      oRecip.Resolve 
      If oRecip.Resolved Then 
       Select Case oRecip.AddressEntry.AddressEntryUserType 
        Case 0, 5 'olExchangeUserAddressEntry & olExchangeRemoteUserAddressEntry 
         Set oEU = oRecip.AddressEntry.GetExchangeUser 
         If Not (oEU Is Nothing) Then 
          ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress 
         End If 
        Case 10, 30 'olOutlookContactAddressEntry & 'olSmtpAddressEntry 
          ResolveDisplayNameToSMTP = oRecip.AddressEntry.Address 
       End Select 
      Else 
       ResolveDisplayNameToSMTP = sFromName 
      End If 
     Case Else 
      'Name not resolved so return sFromName. 
      ResolveDisplayNameToSMTP = sFromName 
    End Select 
End Function