如何在 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”窗口中点击“工具”>“引用”，在弹出的“引用-Project 1”对话框中，从“可用引用”列表中勾选“Microsoft Scripting Runtime”，如截图所示：

5. 单击“确定”以关闭对话框，然后按下“F5”键运行代码。在弹出的“浏览文件夹”对话框中，选择要导出联系人信息的文件夹，如下图所示：

6. 接着点击“确定”，所有包含照片的联系人信息将分别导出到您指定的文件夹中，如下截图所示：