Access VBA to get e-mail address from Outlook 2003 and 2010

Access VBA to get e-mail address from Outlook 2003 and 2010: "Function GetSMTPAddress(ByVal strAddress As String)
' As supplied by Vikas Verma ... see
' http://blogs.msdn.com/vikas/archive/2007/10/24/oom-getting-primary-smtp-address-from-x400-x500-sip-ccmail-etc.aspx
Dim olApp As Object
Dim oCon As Object
Dim strKey As String
Dim oRec As Object
Dim strRet As String
Dim fldr As Object
'IF OUTLOOK VERSION IS >= 2007 THEN USES NATIVE OOM PROPERTIES AND METHODS
On Error Resume Next
Set olApp = Application
Set fldr = olApp.GetNamespace("MAPI").GetDefaultFolder(10).folders.Item("Random")
If fldr Is Nothing Then
olApp.GetNamespace("MAPI").GetDefaultFolder(10).folders.Add "Random"
Set fldr = olApp.GetNamespace("MAPI").GetDefaultFolder(10).folders.Item("Random")
End If
On Error GoTo 0
If CInt(Left(olApp.Version, 2)) >= 12 Then
Set oRec = olApp.Session.CreateRecipient(strAddress)
If oRec.Resolve Then
strRet = oRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
End If
End If
If Not strRet = "" Then GoTo ReturnValue
'IF OUTLOOK VERSION IS < 2007 THEN USES LITTLE HACK
'How it works
'============
'1) It will create a new contact item
'2) Set it's email address to the value passed by you, it could be X500,X400 or any type of email address stored in the AD
'3) We will assign a random key to this contact item and save it in its Fullname to search it later
'4) Next we will save it to local contacts folder
'5) Outlook will try to resolve the email address & make AD call if required else take the Primary SMTP address from its cache and append it to Display name
'6) The display name will be something like this " ( email.address@server.com )"
'7) Now we need to parse the Display name and delete the contact from contacts folder
'8) Once the contact is deleted it will go to Deleted Items folder, after searching the contact using the unique random key generated in step 3
'9) We then need to delete it from Deleted Items folder as well, to clean all the traces
Set oCon = fldr.items.Add(2)
oCon.Email1Address = strAddress
strKey = "_" & Replace(Rnd * 100000 & Format(Now, "DDMMYYYYHmmss"), ".", "")
oCon.FullName = strKey
oCon.Save
strRet = Trim(Replace(Replace(Replace(oCon.Email1DisplayName, "(", ""), ")", ""), strKey, ""))
oCon.Delete
Set oCon = Nothing
Set oCon = olApp.Session.GetDefaultFolder(3).items.Find("[Subject]=" & strKey)
If Not oCon Is Nothing Then oCon.Delete
ReturnValue:
GetSMTPAddress = strRet
End Function

"



'via Blog this'