Αυτό το VBA θα προσθέσει αυτόματα τον αποστολέα και όλους τους παραλήπτες ενός email ως νέες επαφές όταν απαντάτε στο email στο Outlook. Κάντε τα εξής:

1. Τύπος άλλος + F11 για να ανοίξετε το παράθυρο της Microsoft Visual Basic for Applications.

2. Αναπτύξτε το Project1 και κάντε διπλό κλικ Αυτό το OutlookSession για να το ανοίξετε και, στη συνέχεια, επικολλήστε κάτω από τον κώδικα VBA στο παράθυρο ThisOutlookSession. Δείτε το στιγμιότυπο οθόνης:

VBA: Αυτόματη προσθήκη επαφών από ένα μήνυμα ηλεκτρονικού ταχυδρομείου κατά την απάντηση στο Outlook

Public WithEvents xExplorer As Outlook.Explorer
Public WithEvents xMailItem As Outlook.MailItem
Sub Application_Startup()
Set xExplorer = Outlook.Application.ActiveExplorer
End Sub

Private Sub xExplorer_SelectionChange()
On Error Resume Next
Set xMailItem = xExplorer.Selection.Item(1)
End Sub

Private Sub xMailItem_Reply(ByVal Response As Object, Cancel As Boolean)
Dim xNameSpace As NameSpace
Dim xSenderAddress As String
Dim xContactItems As Outlook.Items
Dim i, k As Long
Dim xFilterAddress As String
Dim xContact As Outlook.ContactItem
Dim xNewContact As Outlook.ContactItem
Dim Arr() As String
Dim ArrName() As String
Dim xArrCount As Integer
On Error Resume Next
ReDim Arr(xMailItem.Recipients.Count + 1)
ReDim ArrName(xMailItem.Recipients.Count + 1)
xSenderAddress = xMailItem.SenderEmailAddress
Arr(0) = xSenderAddress
ArrName(0) = xMailItem.SenderName
For i = LBound(Arr) + 1 To UBound(Arr) - 1
Arr(i) = xMailItem.Recipients.Item(i).Address
ArrName(i) = xMailItem.Recipients.Item(i).Name
Next i
Set xNameSpace = Outlook.Application.GetNamespace("MAPI")
Set xContactItems = xNameSpace.GetDefaultFolder(olFolderContacts).Items
For i = LBound(Arr) To UBound(Arr) - 1
For k = 1 To 3
xFilterAddress = "[Email" & k & "Address] = " & Arr(i)
Set xContact = xContactItems.Find(xFilterAddress)
If Not (xContact Is Nothing) Then
Exit For
End If
Next k
If xContact Is Nothing Then
Set xNewContact = Outlook.Application.CreateItem(olContactItem)
With xNewContact
.FullName = ArrName(i)
.Email1Address = Arr(i)
.Categories = "From Email"
.Save
End With
End If
Next i
End Sub

3. Αποθηκεύστε τον κώδικα VBA και επανεκκινήστε το Microsoft Outlook.

Από τώρα και στο εξής, όταν απαντάτε ένα email στο Outlook, ο αποστολέας αυτού του μηνύματος και όλοι οι παραλήπτες θα αποθηκεύονται αυτόματα ως νέες επαφές στον προεπιλεγμένο φάκελο επαφών του προεπιλεγμένου λογαριασμού email.

Πώς να προσθέσετε μαζικές επαφές από τα απεσταλμένα email / φάκελο στο Outlook;

Πώς να προσθέσετε μαζικές επαφές στην ομάδα επαφών στο Outlook;