如何在Outlook中導出聯絡人的信息以及照片?
當您從Outlook導出聯絡人到文件時,只能導出聯絡人的文字信息。但是,有時候您需要同時導出照片和聯絡人的文字信息,該如何在Outlook中處理這個任務呢?
使用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. 然後點擊「確定」,所有帶有照片的聯絡人信息都已分別導出到您的指定文件夾中,參見截圖:

最佳 Office 生產力工具
最新消息:Kutools for Outlook 推出免費版本!
體驗全新 Kutools for Outlook,擁有100+ 強大功能!立即下載!
🤖 Kutools AI :運用先進 AI 技術,輕鬆處理郵件,包括答覆、摘要、優化、擴寫、翻譯與撰寫郵件。
📧 郵件自動化:自動回覆(支援 POP 和 IMAP) / 計劃發送郵件 / 發送郵件時根據規則自動抄送密送 / 自動轉發(高級規則) / 自動新增問候語 / 自動將多收件人郵件分割為個別郵件 ...
📨 郵件管理:撤回郵件 /依主題等條件阻擋詐騙郵件 / 刪除重複郵件 / 高級搜索 / 整合文件夾 ...
📁 附件專業版:批次保存 / 批次拆離 / 批次壓縮 / 自動保存 / 自動拆離 / 自動壓縮 ...
🌟 介面魔法:😊更多精美酷炫表情符號 /重要郵件來臨提醒 / 最小化 Outlook 而非關閉 ...
👍 一鍵神技:帶附件全部答復 /反釣魚郵件 / 🕘顯示發件人時區 ...
👩🏼🤝👩🏻 聯絡人與日曆:批次從選中郵件新增聯絡人 / 將聯絡人組分割為多個組 / 移除生日提醒 ...
以您偏好的語言使用 Kutools —— 支援英語、西班牙語、德語、法語、中文及40 多種其他語言!
只需一鍵即可立即啟用 Kutools for Outlook。立即下載,提升您的效率!

