Hi All,

For what it's worth getting contact info in SMTP format for me was tough.
Turns out half of my contacts are coded as SMTP when they're really exchange
(EX or X500) type. Anyhow, this thread was very useful, so to give back
some...please find below my Visual Basic Scripting (VBS) code to extract SMTP
address from the contact book, evaluate them (to see if they are really SMTP
or exchange), contact the Exchange to get the SMTP value if they are
exchange, and dump it all to an Excel spreadsheet.

Thanks to Dmitri for that awesome Redemption work, without which this would
have been dare I say inprobable!!!

Regards!

'**************************************
'**************************************
'**************************************
Dim myItem
Dim myContacts
Dim myContact
Dim addressEntry
Dim RDOSession
Dim RDOAddressEntry
Dim Recipient

Dim objXL
Dim myOlApp
Dim utils
Dim myNamespace
Dim value

Set objXL = WScript.CreateObject("Excel.Application")
set utils = CreateObject("Redemption.MAPIUtils")
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
set RDOSession = CreateObject("Redemption.RDOSession")
RDOSession.MAPIOBJECT=myOlApp.Session.MAPIOBJECT
Set myContacts = RDOSession.GetDefaultFolder(10).Items

objXL.Visible = TRUE
objXL.WorkBooks.Add
objXL.Columns(1).ColumnWidth = 40
objXL.Columns(2).ColumnWidth = 40
objXL.Columns(3).ColumnWidth = 40
objXL.Cells(1, 1).Value = "Name"
objXL.Cells(1, 1).Font.Bold = TRUE
objXL.Cells(1, 2).Value = "Nickname"
objXL.Cells(1, 2).Font.Bold = TRUE
objXL.Cells(1, 3).Value = "Email Address"
objXL.Cells(1, 3).Font.Bold = TRUE

Dacount = 1

For each myContact in myContacts

if TypeName(myContact)= "RDOContactItem" Then

result =
utils.GetIDsFromNames(myContact.MAPIOBJECT,"{00062 004-0000-0000-C000-000000000046}",&H8085,false)
value = utils.HrGetOneProp(myContact.MAPIOBJECT, result)

if not isempty(value) then

Dacount = Dacount + 1
entryID = utils.HrArrayToString(value)

set RDOAddressEntry = RDOSession.GetAddressEntryFromID( entryID)
smtpEmailAddress= RDOAddressEntry.SmtpAddress

objXL.Cells(Dacount, 1).value = myContact.FirstName+"
"+myContact.LastName
objXL.Cells(Dacount, 2).value = myContact.NickName

if mid(smtpEmailAddress,1,2) = "/o" then

foundSMTP = InStr(1,smtpEmailAddress,"SMTP:")
if foundSMTP 0 then
smtpEmailAddress=mid(smtpEmailAddress,foundSMTP+5)
objXL.Cells(Dacount, 3).value = smtpEmailAddress
else
foundSMTP = InStr(1,smtpEmailAddress,"Recipients/cn=")
smtpEmailAddress=mid(smtpEmailAddress,foundSMTP+14 )
set Recipient = utils.CreateRecipient(smtpEmailAddress,
0,0)

if Recipient.Resolved then
objXL.Cells(Dacount, 3).value =
Recipient.AddressEntry.SMTPAddress
else
smtpEmailAddress = "***Not avialable***"
objXL.Cells(Dacount, 3).value = smtpEmailAddress
objXL.Cells(Dacount, 3).Font.Bold = TRUE
end if
end if

else
if smtpEmailAddress = "" then
smtpEmailAddress = "***Not avialable***"
objXL.Cells(Dacount, 3).value = smtpEmailAddress
objXL.Cells(Dacount, 3).Font.Bold = TRUE
end if

objXL.Cells(Dacount, 3).value = smtpEmailAddress

end if

end if

end if
next

msgbox "Contact extraction done!",,"Contact extractor"