Как экспортировать контактные данные вместе с фотографиями в Outlook?

При экспорте контактов из Outlook сохраняется только текстовая информация. Но что делать, если нужно экспортировать и фотографии, и текстовые данные контактов? Как решить эту задачу в Outlook?

Экспорт информации контактов с соответствующими фотографиями с помощью кода VBA

---

Экспорт информации контактов с соответствующими фотографиями с помощью кода VBA

Приведённый ниже код VBA позволяет экспортировать все контакты из выбранной папки контактов в отдельные текстовые файлы, включая фотографии. Выполните следующие действия:

1. Выберите папку контактов, из которой нужно экспортировать контакты вместе с их фотографиями.

2. Затем нажмите сочетание клавиш «ALT» + «F11», чтобы открыть окно Microsoft Visual Basic for Applications.

3. Затем выберите «Вставка» > «Модуль», скопируйте приведённый ниже код и вставьте его в открывшийся пустой модуль (см. снимок экрана):

Код VBA: экспорт информации контактов с фотографиями

Sub BatchExportContactPhotosandInformation()
Dim xContactItems As Outlook.Items
Dim xItem As Object
Dim xContactItem As ContactItem
Dim xContactInfo As String
Dim xShell As Object
Dim xFSO As Scripting.FileSystemObject
Dim xTextFile As Scripting.TextStream
Dim xAttachments As Attachments
Dim xAttachment As Attachment
Dim xSavePath, xEmailAddress As String
Dim xFolder As Outlook.Folder
On Error Resume Next
Set xFSO = CreateObject("Scripting.FileSystemObject")
Set xShell = CreateObject("Shell.application").BrowseforFolder(0, "Select a Folder", 0, 16)
If xShell Is Nothing Then Exit Sub
xSavePath = xShell.Items.Item.Path & "\"
If Outlook.Application.ActiveExplorer.CurrentFolder.DefaultItemType <> olContactItem Then
    Set xFolder = Outlook.Application.Session.GetDefaultFolder(olFolderContacts)
Else
    Set xFolder = Outlook.Application.ActiveExplorer.CurrentFolder
End If
Set xContactItems = xFolder.Items
For i = xContactItems.Count To 1 Step -1
    Set xItem = xContactItems.Item(i)
    If xItem.Class = olContact Then
        Set xContactItem = xItem
        With xContactItem
            xEmailAddress = .Email1Address
            If Len(Trim(.Email2Address)) <> 0 Then
                xEmailAddress = xEmailAddress & ";" & .Email2Address
            End If
            If Len(Trim(.Email3Address)) <> 0 Then
                xEmailAddress = xEmailAddress & ";" & .Email3Address
            End If
            xContactInfo = "Name: " & .FullName & vbCrLf & "Email: " & _
                           xEmailAddress & vbCrLf & "Company: " & .CompanyName & _
                           vbCrLf & "Department: " & .Department & _
                           vbCrLf & "Job Title: " & .JobTitle & _
                           vbCrLf & "IM: " & .IMAddress & _
                           vbCrLf & "Business Phone: " & .BusinessTelephoneNumber & _
                           vbCrLf & "Home Phone: " & .HomeTelephoneNumber & _
                           vbCrLf & "BusinessFax Phone: " & .BusinessFaxNumber & _
                           vbCrLf & "Mobile Phone: " & .MobileTelephoneNumber & _
                           vbCrLf & "Business Address: " & .BusinessAddress
            Set xTextFile = xFSO.CreateTextFile(xSavePath & .FullName & ".txt", True)
            xTextFile.WriteLine xContactInfo
            If .Attachments.Count > 0 Then
                Set xAttachments = .Attachments
                For Each xAttachment In xAttachments
                    If InStr(LCase(xAttachment.FileName), "contactpicture.jpg") > 0 Then
                        xAttachment.SaveAsFile (xSavePath & .FullName & ".jpg")
                    End If
                Next
            End If
        End With
    End If
Next i
End Sub

4. После вставки кода в модуль перейдите в меню «Сервис» → «Ссылки» в окне Microsoft Visual Basic for Applications. В открывшемся диалоговом окне «Ссылки – Project1» установите флажок напротив пункта «Microsoft Scripting Runtime» в списке «Доступные ссылки» (см. снимок экрана):

5. Нажмите «ОК», чтобы закрыть диалоговое окно, затем нажмите клавишу F5 для запуска кода. В появившемся окне «Выбор папки» укажите папку, в которую нужно сохранить экспортированные контакты (см. снимок экрана):

6. Затем нажмите «ОК» — вся информация с фотографиями контактов будет экспортирована в указанную папку в виде отдельных файлов (см. снимок экрана):