如何在 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」視窗中點選「工具」>「參考」，在彈出的「References-Project 1」對話方塊中，於「可用參考項目」清單方塊內勾選「Microsoft Scripting Runtime」選項，如下圖所示：

5. 按一下「確定」關閉對話方塊，然後按下「F5」鍵執行此程式碼，在彈出的「瀏覽資料夾」對話方塊中，指定您要儲存匯出聯絡人的資料夾位置，如下圖所示：

6. 接著按一下「確定」，所有聯絡人的資訊與其照片便會分別匯出至您指定的資料夾中，如下圖所示：