Copiare e incollare il seguente script;
Public Sub IndirizziDestinatari()
Dim currentExplorer As Explorer
Dim Selezione As Selection
Dim obj, objMail As Object
Dim objProp As Outlook.UserProperty
Dim strDomain
Dim Recipients As Outlook.Recipients
Dim recip As String 'Casella di posta
Dim i
Set currentExplorer = Application.ActiveExplorer
Set Selezione = currentExplorer.Selection
On Error Resume Next
For Each obj In Selezione
Set objMail = obj
strDomain = ""
Set Recipients = objMail.Recipients
For i = Recipients.count To 1 Step -1
recip$ = Recipients.item(i).Address
' Per elaborare gli indirizzi x.500
If InStr(1, LCase(recip), "/ou=") Then recip = Right(recip, Len(recip) - InStr(1, LCase(recip), "recipients") - 13)
' Aggiunge ; se sono presenti più indirizzi
If i = 1 Then
strDomain = strDomain & recip
Else
strDomain = strDomain & recip & "; "
End If
Next i
Debug.Print strDomain
Set objProp = objMail.UserProperties.Add("Destinatari", olText, True)
objProp.Value = strDomain
objMail.Save
Err.Clear
Next
Set currentExplorer = Nothing
Set obj = Nothing
Set Selezione = Nothing
End Sub