Question

我正在为Outlook实现一个VBA脚本，该脚本应该检索每封电子邮件的信息，例如收到的日期，发送日期，发件人等等。然后将此数据传输到Excel表中。

我还必须提一下，我将运行此脚本的邮箱是共享收件箱。

到目前为止，我所做的一切都很有效。但是，我正在考虑添加一个功能，即添加回复者的电子邮件地址，如果已经回复了收件箱电子邮件。

只是澄清一下，回复者我指的是有权访问公共邮箱并回复收到的电子邮件的用户。由于我们的邮箱是共享的，因此会增加更多的复杂性，因为有时回复者会代表mailboxToRunReportOn@example.com回复，有时会回复自己。

现在，我已经完成了一些研究，但我无法找到MAPI或MailItem的任何可以检索电子邮件回复者的名称。收件箱电子邮件。以下是我查看MailItem propertes和MAPI properties的链接。

因此，我的问题是，我应该怎么做呢？

以下是我迄今为止在代码方面取得的成就：

Sub ReportResponses()
    Dim objNS As Outlook.NameSpace
    Dim objFolder As Outlook.Folder
    Dim objTable As Outlook.Table
    Dim objRow As Outlook.Row
    Dim objEX As Object
    Dim objWB As Object
    Dim objWS As Object
    Dim intR As Integer
    Dim val()
    Const PR_LAST_VERB_EXECUTION_TIME = "http://schemas.microsoft.com/mapi/proptag/0x10820040"
    Const PR_LAST_VERB_EXECUTED = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
    On Error Resume Next

    Set objNS = Application.GetNamespace("MAPI")
    Set objFolder = objNS.PickFolder
    Set objTable = objFolder.GetTable

    With objTable
        .Columns.RemoveAll
        .Columns.Add "SenderName"
        .Columns.Add "Subject"
        .Columns.Add "SentOn"
        .Columns.Add "UnRead"
        .Columns.Add PR_LAST_VERB_EXECUTION_TIME 'returns reply date
    End With
    If objTable.GetRowCount > 0 Then
        Set objEX = CreateObject("Excel.Application")
        Set objWB = objEX.Workbooks.Add
        Set objWS = objWB.Worksheets(1)
        intR = 4
        Do Until objTable.EndOfTable
            Set objRow = objTable.GetNextRow
            val = objRow.GetValues
            With objWS
                .Cells(intR, 1).Value = val(0)
                .Cells(intR, 2).Value = val(1)
                .Cells(intR, 3).Value = val(2)
                .Cells(intR, 4).Value = didReadMail(val(3))
                .Cells(intR, 5).Value = val(4)
                If IsDate(val(4)) Then
                    .Cells(intR, 6).Value = Hour(TimeDiff((CDate(val(4))), (CDate(val(2)))))
                End If
            End With
            intR = intR + 1
        Loop
        With objWS
            .Columns("A:G").EntireColumn.AutoFit
            .Cells(1, 1).Value = "Report on Messages in Folder: " & objFolder.FolderPath
            .Cells(3, 1).Value = "From"
            .Cells(3, 2).Value = "Subject"
            .Cells(3, 3).Value = "Received On"
            .Cells(3, 4).Value = "DidRead"
            .Cells(3, 5).Value = "Replied On"
            .Cells(3, 6).Value = "Resonse time in h"
            .Range("A1:G3").Font.Bold = True
            .Columns("D").EntireColumn.AutoFit
            .Range("A4").AutoFilter
        End With
        objEX.Visible = True
        objWB.Activate
    End If
    Set objTable = Nothing
    Set objRow = Nothing
    Set objEX = Nothing
    Set objWS = Nothing
End Sub

Function TimeDiff(ByRef StartTime As Date, ByRef StopTime As Date) As Date
    TimeDiff = CDate((StopTime - StartTime))
End Function

Function didReadMail(ByVal isUnread As Boolean) As Boolean
    If isUnread = False Then
        didReadMail = True
    Else
        didReadMail = False
    End If
End Function

Answer 1

尝试MailItem.ReceivedByName属性。

如果您想要修改消息的最后一个用户的名称（如果用户回复了消息，消息将被修改），请使用PR_LAST_MODIFIER_NAME属性DASL名称（http://schemas.microsoft.com/mapi/proptag/0x3FFA001F）。您还可以尝试检索PR_LAST_MODIFIER_ENTRYID（DASL名称http://schemas.microsoft.com/mapi/proptag/0x3FFB0102），将其转换为十六进制，然后使用AddressEntry将其作为Namespace.GetAddressEntryFromID对象打开。

在Outlook VBA

1 个答案: