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．「OK」をクリックしてダイアログを閉じ、その後「F5」キーを押してこのコードを実行します。すると、「フォルダーの参照」ダイアログボックスが表示されるので、エクスポートした連絡先を保存したいフォルダーを指定してください（スクリーンショット参照）。

6．「OK」をクリックすると、連絡先の情報と写真がすべて、指定したフォルダーに個別にエクスポートされます（スクリーンショット参照）。