メールのスレッドを保持してExcelにエクスポートするマクロ (エイリアス バージョン)


メールのスレッドを保持してExcelにエクスポートするマクロのコメントにて以下のご要望をいただきました。


大変便利なマクロを披露していただき、ありがとうございます。
自分が使用している環境では、宛先、Cc、差出人がすべて「表示名」で表示され->Excelの表にも表示名で記入されます。
この表示名をエイリアスの表示に切り替えるにはどうすればよいでしょうか。

よろしくご教示ください


エイリアス、ということは Exchange サーバー環境でしょうか?
その場合、差出人や受信者のオブジェクトで GetExchangeUser などにより Exchange 情報を取得する必要があります。
マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。

Option Explicit
' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ExportToExcelWithThread()
    On Error Resume Next
    Dim appExcel 'As Excel.Application
    Dim objBook 'As Excel.Workbook
    Dim objSheet 'As Excel.Worksheet
    Dim bConvOK As Boolean
    Dim colItems As Items
    Dim objItem 'As MailItem
    Dim c As Integer
    '
    Set appExcel = CreateObject("Excel.Application")
    Set objBook = appExcel.Workbooks.Add()
    Set objSheet = objBook.Sheets(1)
    With objSheet
        .Cells(1, 1) = "スレッド情報"
        .Cells(1, 2) = "日付"
        .Cells(1, 3) = "宛先"
        .Cells(1, 4) = "Cc"
        .Cells(1, 5) = "差出人"
        .Cells(1, 6) = "件名"
        .Cells(1, 7) = "本文"
    '
        Set colItems = ActiveExplorer.CurrentFolder.Items
        colItems.Sort "送信日時"
        bConvOK = ActiveExplorer.CurrentFolder.Store.IsConversationEnabled
        For Each objItem In colItems
            If bConvOK Then
                ExportThreadByConversation objItem, objSheet
            Else
                ExportThreadByMessageId objItem, objSheet
            End If
        Next
        For c = 2 To .UsedRange.Columns.Count Step 6
            .Cells(1, c) = "日付"
            .Cells(1, c + 1) = "宛先"
            .Cells(1, c + 2) = "Cc"
            .Cells(1, c + 3) = "差出人"
            .Cells(1, c + 4) = "件名"
            .Cells(1, c + 5) = "本文"
        Next
    End With
    '
    appExcel.Visible = True
    objBook.Windows(1).Visible = True
End Sub
'
Private Sub ExportThreadByConversation(objItem, objSheet)
    Const PR_CONVERSATION_ID = "http://schemas.microsoft.com/mapi/proptag/0x30130102"
    Dim strConvID As String
    Dim r As Integer
    Dim c As Integer
    '
    With objItem.PropertyAccessor
        strConvID = .BinaryToString(.GetProperty(PR_CONVERSATION_ID))
    End With
    r = 2
    While objSheet.Cells(r, 1) <> ""
        If objSheet.Cells(r, 1) = strConvID Then
            Exit Sub
        End If
        r = r + 1
    Wend
    objSheet.Cells(r, 1) = strConvID
    c = 2
    EnumConversation objItem.GetConversation().GetRootItems, objSheet, r, c
End Sub
'
Private Sub EnumConversation(colItems As SimpleItems, objSheet, r As Integer, c As Integer)
    Dim objItem 'As MailItem
    Dim conv As Conversation
    Dim colSubItems As SimpleItems
    For Each objItem In colItems
        WriteCell objItem, objSheet, r, c
        c = c + 6
        Set conv = objItem.GetConversation()
        Set colSubItems = conv.GetChildren(objItem)
        If colSubItems.Count > 0 Then
            EnumConversation colSubItems, objSheet, r, c
        End If
    Next
End Sub
'
Private Sub ExportThreadByMessageId(objItem, objSheet)
    Const PR_INTERNET_MESSAGE_ID = "http://schemas.microsoft.com/mapi/proptag/0x1035001e"
    Const PR_IN_REPLY_TO_ID = "http://schemas.microsoft.com/mapi/proptag/0x1042001e"
    Dim strMsgID As String
    Dim strRepID As String
    Dim r As Integer
    Dim c As Integer
    Dim bFound As Boolean
    '
    With objItem.PropertyAccessor
        strMsgID = .GetProperty(PR_INTERNET_MESSAGE_ID)
        strRepID = .GetProperty(PR_IN_REPLY_TO_ID)
    End With
    '
    With objSheet
        c = 2
        If strRepID = "" Then
            r = .UsedRange.Rows.Count + 1
        Else
            bFound = False
            r = 2
            While (Not bFound) And .Cells(r, 1) <> ""
                If InStr(.Cells(r, 1), strRepID) > 0 Then
                    While .Cells(r, c) <> ""
                        c = c + 6
                    Wend
                    bFound = True
                Else
                    r = r + 1
                End If
            Wend
        End If
        .Cells(r, 1) = .Cells(r, 1) & strMsgID
        WriteCell objItem, objSheet, r, c
    End With
End Sub
'
Private Sub WriteCell(objItem, objSheet, r As Integer, c As Integer)
    On Error Resume Next
    With objSheet
        .Cells(r, c) = objItem.SentOn
        .Cells(r, c + 1) = GetRecipAliases(objItem, olTo)
        .Cells(r, c + 2) = GetRecipAliases(objItem, olCC)
        .Cells(r, c + 3) = GetAlias(objItem.Sender)
        .Cells(r, c + 4) = objItem.Subject
        .Cells(r, c + 5) = objItem.Body
    End With
End Sub
'
Private Function GetRecipAliases(objItem, iType As OlMailRecipientType)
    Dim strAliases As String
    Dim objRecip As Recipient
    strAliases = ""
    For Each objRecip In objItem.Recipients
        If objRecip.Type = iType Then
            strAliases = strAliases & GetAlias(objRecip.AddressEntry) & ";"
        End If
    Next
    If strAliases <> "" Then
        strAliases = Left(strAliases, Len(strAliases) - 1)
    End If
    GetRecipAliases = strAliases
End Function
'
Private Function GetAlias(addrEntry As AddressEntry)
    On Error Resume Next
    Dim exchUser As ExchangeUser
    Dim exchDl As ExchangeDistributionList
    Dim strAlias As String
    Set exchUser = addrEntry.GetExchangeUser()
    Set exchDl = addrEntry.GetExchangeDistributionList()
    If Not exchUser Is Nothing Then
        strAlias = exchUser.Alias
    ElseIf Not exchDl Is Nothing Then
        strAlias = exchDl.Alias
    Else
        strAlias = addrEntry.Address
    End If
    GetAlias = strAlias
End Function

マクロの登録方法やメニューへの追加について

広告

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト / 変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト / 変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト / 変更 )

Google+ フォト

Google+ アカウントを使ってコメントしています。 ログアウト / 変更 )

%s と連携中