Outlook MeetingItem无MeetingResponseStatus属性，如何提取会议提议新时间？

1. 修正核心属性调用错误 #

MeetingItem对象本身不支持MeetingResponseStatus属性，该属性属于关联的约会对象（AppointmentItem）。必须先通过GetAssociatedAppointment(True)获取对应的会议约会，再判断响应状态：

' 替换原有的If objMeeting.MeetingResponseStatus = olResponseAccepted Then
Dim objAppt As Outlook.AppointmentItem
Set objAppt = objMeeting.GetAssociatedAppointment(True)
If Not objAppt Is Nothing Then
    If objAppt.MeetingResponseStatus = olResponseAccepted Then
        ' 后续业务逻辑
    End If
End If

2. 修复发件人引用错误 #

处理MeetingItem时，原代码中的objMail未赋值（仅处理MailItem时才会初始化），直接调用objMail.SenderName会触发错误，需改用objMeeting.SenderName：

' 替换原有的objWorksheet.Cells(lngRow, 1).Value = objMail.SenderName
objWorksheet.Cells(lngRow, 1).Value = objMeeting.SenderName

3. 调整会议状态判断逻辑 #

原代码的MeetingStatus判断逻辑不准确，针对含新时间提议的会议响应，应检查关联约会的状态是否为olMeetingReceivedAndAccepted或olMeetingReceivedAndTentative，结合正文关键词筛选：

' 替换原有的MeetingStatus判断代码
If (objAppt.MeetingStatus = olMeetingReceivedAndAccepted Or objAppt.MeetingStatus = olMeetingReceivedAndTentative) Then
    If InStr(1, objMeeting.Body, "new time proposed", vbTextCompare) > 0 Then
        strNewTimeProposed = objAppt.Start
        lngRow = objWorksheet.Cells(objWorksheet.Rows.Count, 1).End(xlUp).Row + 1
        objWorksheet.Cells(lngRow, 1).Value = objMeeting.SenderName
        objWorksheet.Cells(lngRow, 2).Value = strNewTimeProposed
    End If
End If

完整修正后的核心循环代码 #

' 遍历收件箱中的项目
For Each objItem In objMailItems
    If TypeOf objItem Is Outlook.MailItem Then
        Set objMail = objItem
        Debug.Print "Processing email: " & objMail.Subject
    ElseIf TypeOf objItem Is Outlook.MeetingItem Then
        Set objMeeting = objItem
        Dim objAppt As Outlook.AppointmentItem
        Set objAppt = objMeeting.GetAssociatedAppointment(True)
        
        If Not objAppt Is Nothing Then
            ' 检查是否为已接受的会议响应
            If objAppt.MeetingResponseStatus = olResponseAccepted Then
                ' 检查是否包含新时间提议
                If (objAppt.MeetingStatus = olMeetingReceivedAndAccepted Or objAppt.MeetingStatus = olMeetingReceivedAndTentative) Then
                    If InStr(1, objMeeting.Body, "new time proposed", vbTextCompare) > 0 Then
                        strNewTimeProposed = objAppt.Start
                        lngRow = objWorksheet.Cells(objWorksheet.Rows.Count, 1).End(xlUp).Row + 1
                        objWorksheet.Cells(lngRow, 1).Value = objMeeting.SenderName
                        objWorksheet.Cells(lngRow, 2).Value = strNewTimeProposed
                    End If
                End If
            End If
        End If
    End If
Next objItem

额外注意事项 #

• 确保已引用Outlook对象库：打开VBA编辑器 → 工具 → 引用 → 勾选Microsoft Outlook XX.X Object Library（XX.X对应你的Outlook版本）。
• 若提取的时间显示异常，可使用Format(strNewTimeProposed, "yyyy-mm-dd hh:mm:ss")格式化后写入Excel。

内容的提问来源于stack exchange，提问作者Geórgia Brito