从Excel中的联系人列表中通过电子邮件ID获取姓名

我有一个Excel表中的电子邮件ID列表，我想使用VBA脚本从Outlook联系人列表中获取他们的名字。 我在网上search，但没有find为我工作的东西？

如何做到这一点？

Answer 1

以下的作品。 下面的代码获取对应于“[e-mail]”的名称您可以使用一个数组并比较我的想法。 不知道是否有更好的方法。

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 = "[e-mail]" 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 <[e-mail]> ， My Name ， [e-mail]

 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