Function GetEmailAddress(ByVal name As String) As String
Dim oApp As Outlook.Application
Set oApp = New Outlook.Application
Dim oNamespace As Outlook.Namespace
Set oNamespace = oApp.GetNamespace("MAPI")
Dim oAddressList As Outlook.AddressList
Set oAddressList = oNamespace.GetDefaultFolder(olFolderContacts).AddressList
Dim oRecipient As Outlook.Recipient
Set oRecipient = oNamespace.CreateRecipient(name)
If oRecipient.Resolve Then
GetEmailAddress = oRecipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress
Else
GetEmailAddress = ""
End If
Set oRecipient = Nothing
Set oAddressList = Nothing
Set oNamespace = Nothing
Set oApp = Nothing
End Function