Dear bigjosh-ga,
Thank you for the interesting question. I've coded up a quick macro in
VBA which should do nicely for you, and, as requested, I've tested it
here (against Outlook 2002, SP2).
Depending on your settings, you may need to lower your Outlook Macro
Security settings, or sign the project you create to contain this, in
order for this to run for you. Also, when you run it, you will receive
a warning from Outlook that a program is trying to access your address
book - this is normal; check the box to allow it access for ten
minutes.
To set it up, open "Tools"/"Macro"/"Visual Basic Editor" and insert a
new module into the project. Paste the code below into that module:
Dim ns As NameSpace
Dim contacts As MAPIFolder
Dim sentItems As MAPIFolder
Dim sentII As Items
Dim current As MailItem
Dim ciRecip As Recipients
Dim ri As Long
Dim cirName As String
Dim cirAddress As String
Dim newContact As ContactItem
Dim dupes As New Dictionary
Dim processed As Long
Sub Main()
' Get the namespace for the current Outlook session
Set ns = Application.GetNamespace("MAPI")
' Get the contacts and sent items folders
Set contacts = ns.GetDefaultFolder(olFolderContacts)
Set sentItems = ns.GetDefaultFolder(olFolderSentMail)
' Iterate through every item in the Sent Items folder
Set sentII = sentItems.Items
Set current = sentII.GetFirst
processed = 0
Do
' Extract the relevant information from the MailItem
' Namely, the recipients from each
Set ciRecip = current.Recipients
For ri = 1 To ciRecip.Count
' Extract the information
With ciRecip.Item(ri)
cirName = .Name
cirAddress = .Address
End With
' Strip off leading and trailing apostrophes from the full
name
If Left$(cirName, 1) = "'" Then
cirName = Right$(cirName, Len(cirName) - 1)
End If
If Right$(cirName, 1) = "'" Then
cirName = Left$(cirName, Len(cirName) - 1)
End If
' Check if the contact already exists
If dupes.Exists(cirAddress) Then
Exit For
End If
' Create the contact
Set newContact = Application.CreateItem(olContactItem)
With newContact
.FullName = cirName
.Email1Address = cirAddress
.Save
End With
' Add the address to the dupes collection
dupes.Add cirAddress, "exists"
Next
' Get the next item; if it is nothing, fall through the loop.
processed = processed + 1
Set current = sentII.GetNext
Loop Until current Is Nothing
' We've iterated through 'em all, now
Call MsgBox("Items processed: " & processed, vbOKOnly, "Import
Complete")
End Sub
You will also need to add "Microsoft Scripting Runtime" to the
referenced modules ("Tools"/"References...").
When you run this macro, it will add every unique e-mail address it
finds in the recipients of messages in your "Sent Items" folder as a
new contact, with the matching display name attached as the full name
of the contact. When it's completed iterating through your entire
"Sent Items" folder, it displays a message box with the number of
messages it has processed as a check for you.
If you run into any problems implementing this, or if this answer
isn't quite what you're looking for, please feel free to request a
clarification,
cerebrate-ga
Search strategy:
Developed for the customer. |