MS Outlook: Автоматическое создание контактов

Случается так, что вы ведете переписку с большим количеством людей и вам нужно всех их добавить в контакты. Можно по очереди открывать письма от разных отправителей и по очереди добавлять каждого отправителя в контакты. Есть другой, более простой способ - использовать макросы Outlook. В последнем варианте процедура создания контактов займет у вас меньше времени и вы сможете без труда просканировать огромное количество писем.

Создадим макрос, который будет сканировать письма и добавлять контакты из них.

1. Запустите Outlook.
2. Откройте Tools->Macro->Visual Basic Editor. Должно открыться окно редактора макросов.
3. Если папка Modules не развернута - разверните ее, затем откройте Module1.
4. Скопируйте код макроса, приведенный ниже и вставьте его в редактор макросов.
5. Закройте окно редактора макросов.
6. Проверьте, чтоб макрос AutoAddContact появился в списке, для этого нажмите Tools->Macro->Macros.
7. Перейдите в папку, в которой содержатся сообщения, которые нужно просканировать.
8. Выберите сообщения, отправителей из которых вы хотите добавить в контакты.
9. Нажмите Tools->Macro->Macros, выберите AutoAddContact и нажмите Run.
10. Откроется диалоговое окно с предупреждением, что программа пытается получить доступ к вашим почтовым сообщениям и спросит расрешения предоставить доступ. Разрешите доступ на 5 минут (этого вполне достаточно для сканирования даже очень большого числа писем). После этого макрос начнет работу, по очереди просканирует все вылеленные сообщения и добавит в список контактов адрес каждого отправителя, если его еще в списке контактов нет.

Макрос, для сканирования входящих писем

Sub AutoAddContact()
    Dim olkContacts As MAPIFolder, _
        olkContact As ContactItem, _
        olkSelected As Selection, _
        olkItem As Object, _
        olkRecip As Recipient, _
        strName As String
    Set olkSelected = Application.ActiveExplorer.Selection
    If olkSelected.Count > 0 Then
        For Each olkItem In olkSelected
            If olkItem.Class = olMail Then
                Set olkContacts = Application.Session.GetDefaultFolder(olFolderContacts)
                For Each olkRecip In olkItem.Recipients
                    strName = olkRecip.Name
                    If Left(strName, 1) = "'" Then strName = Mid(strName, 2)
                    If Right(strName, 1) = "'" Then strName = Mid(strName, 1, Len(strName) - 1)
                    Set olkContact = olkContacts.Items.Find("[FullName] = " & Chr(34) & strName & Chr(34))
                    If TypeName(olkContact) = "Nothing" Then
                        Set olkContact = Application.CreateItem(olContactItem)
                        With olkContact
                            .Email1Address = olkRecip.Address
                            .FullName = strName
                            .Body = "Record created automatically on " & Date & " at " & Time & " by BlueDevilFan's script."
                            .Categories = "Auto Added Contact"
                            .Save
                        End With
                    End If
                Next
            End If
        Next
    End If
    Set olkContact = Nothing
    Set olkContacts = Nothing
    Set olkSelected = Nothing
    Set olkItem = Nothing
    Set olkRecip = Nothing
End Sub

Кастомизированный макрос, на случай, если нужно просканироавать отправленные сообщения.

В этом случае у вас может не быть возможности прочитать поле FullName, поэтому в данном варианте макроса сканируется тело письма на предмет наличия приветствия - как известно, за приветствием обычно следует имя, кого приветствуют.

Attribute VB_Name = "Module1"
Sub AutoAddContact()
    Dim olkContacts As MAPIFolder, _
        olkContact As ContactItem, _
        olkSelected As Selection, _
        olkItem As Object, _
        olkRecip As Recipient, _
        strName As String
    Set olkSelected = Application.ActiveExplorer.Selection
    If olkSelected.Count > 0 Then
        For Each olkItem In olkSelected
            If olkItem.Class = olMail Then
                ' Если это почтовое сообщение, то
                ' продолжаем дальше с ним работать
                sBody = olkItem.Body
 
                ' Массив с приветствиями
                Dim strHello(7) As String
                strHello(0) = "Приветствуем Вас,"
                strHello(1) = "Добрый день,"
                strHello(2) = "И снова здравствуйте,"
                strHello(3) = "Дорогая,"
                strHello(4) = "Привет, прекрасня"
                strHello(5) = "Милая,  дорогая"
                strHello(6) = "Доброго утра/дня/вечера,"
                strHello(7) = "Здравствуйте,"
                sName = ""
 
                For lngPosition = LBound(strHello) To UBound(strHello)
                    sText = strHello(lngPosition)
                    lLen = Len(sText)
                    lPosStart = InStr(sBody, sText)
                    lPosEnd = InStr(sBody, "!")
 
                    If lPosStart > 0 And lPosStart < lPosEnd Then
                        sName = Mid$(sBody, lPosStart + lLen, lPosEnd - lPosStart - lLen)
                    End If
                Next lngPosition

                Set olkContacts = Application.Session.GetDefaultFolder(olFolderContacts)
                For Each olkRecip In olkItem.Recipients
                    strName = olkRecip.Name
                    If Left(strName, 1) = "'" Then strName = Mid(strName, 2)
                    If Right(strName, 1) = "'" Then strName = Mid(strName, 1, Len(strName) - 1)
                    Set olkContact = olkContacts.Items.Find("[Email1Address] = " & Chr(34) & strName & Chr(34))
                    If TypeName(olkContact) = "Nothing" Then
                    '
                        Set olkContact = Application.CreateItem(olContactItem)
                        With olkContact
                            .Email1Address = olkRecip.Address
 
                            If Len(sName) = 0 Then
                                '.FullName = strName
                                .FirstName = strName
                            Else
                                '.FullName = strName
                                .FirstName = sName
                            End If
 
                            .Body = "Record created automatically on " & Date & " at " & Time & " by BlueDevilFan's script.\n Scrips was customized by Alex Kovtun"
                            .Categories = "Auto Added Contact"
                            .Save
                        End With
                    End If
                Next
            End If
        Next
    End If
    Set olkContact = Nothing
    Set olkContacts = Nothing
    Set olkSelected = Nothing
    Set olkItem = Nothing
    Set olkRecip = Nothing
End Sub

Информация почерпнута здесь.