开发VBA代码导入Outlook参会者Proposed Start Time时报错求助

错误原因 #

你代码中的错误源于对Outlook对象模型的误解：ProposedStartTime是**MeetingItem对象的直接属性**，而非GetAssociatedAppointment返回的AppointmentItem对象的属性。原代码尝试从关联预约中读取该属性，自然会触发"对象不支持此属性或方法"的错误。

修正后的完整代码 #

Function SheetExists(sheetName As String, Optional wb As Workbook) As Boolean
    Dim s As Worksheet
    On Error Resume Next
    If wb Is Nothing Then Set wb = ThisWorkbook
    Set s = wb.Sheets(sheetName)
    SheetExists = Not s Is Nothing
End Function

Sub SaveNewTimeProposedToExcel()
    Dim objNamespace As Outlook.Namespace
    Dim objFolder As Outlook.Folder
    Dim objMail As Outlook.MailItem
    Dim strNewTimeProposed As Variant ' 修改为Variant以处理空值
    Dim objWorkbook As Excel.Workbook
    Dim objMeeting As Outlook.MeetingItem
    Dim objItem As Object
    Dim objWorksheet As Excel.Worksheet ' 补充声明变量
    Dim lngRow As Long
    
    Set Base = ActiveWorkbook
    
    ' 定义命名空间和收件箱文件夹
    Set objNamespace = Outlook.Application.GetNamespace("MAPI")
    Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)
    
    ' 打开现有文件
    Set objWorkbook = Workbooks.Open("C:\Users\genascim\Desktop\Gregory Project\Gregory_database.xlsx")
    
    ' 检查“New Time Proposed”工作表是否存在，若存在则创建新工作表
    Dim strSheetName As String
    Dim intSheetCount As Integer
    intSheetCount = 1
    strSheetName = "New Time Proposed"
    Do While SheetExists(strSheetName, objWorkbook)
        intSheetCount = intSheetCount + 1
        strSheetName = "New Time Proposed " & intSheetCount
    Loop
    
    ' 添加新工作表并设置首行标题
    Set objWorksheet = objWorkbook.Sheets.Add(After:=objWorkbook.Sheets(objWorkbook.Sheets.Count))
    objWorksheet.Name = strSheetName
    objWorksheet.Cells(1, 1).Value = "发件人"
    objWorksheet.Cells(1, 2).Value = "提议新时间"
    
    ' 优化日期格式为Outlook兼容的ISO格式，避免区域设置问题
    Dim filterDate As String
    filterDate = Format(Date - 7, "yyyy-mm-dd hh:mm:ss")
    Set objMailItems = objFolder.Items.Restrict("[ReceivedTime] > '" & filterDate & "'")
    
    ' 遍历收件箱中的项目
    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

            ' 检查是否为会议回复
            If objMeeting.MessageClass = "IPM.Schedule.Meeting.Resp.Pos" Or _
               objMeeting.MessageClass = "IPM.Schedule.Meeting.Resp.Neg" Or _
               objMeeting.MessageClass = "IPM.Schedule.Meeting.Resp.Tent" Then
                
                ' 检查回复是否包含新时间提议
                If InStr(1, objMeeting.Subject, "New Time Proposed", vbTextCompare) > 0 Then
                    ' 直接从MeetingItem读取提议时间，补充空值检查
                    If Not IsEmpty(objMeeting.ProposedStartTime) Then
                        strNewTimeProposed = objMeeting.ProposedStartTime
                    Else
                        strNewTimeProposed = "无有效提议时间" ' 处理空值情况
                    End If

                    ' 将发件人和提议新时间添加到工作表
                    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
    Next objItem
    
    ' 保存工作簿
    objWorkbook.Save
    
End Sub

关键修改说明 #

1. 核心错误修复：移除objMeeting.GetAssociatedAppointment(True).ProposedStartTime，直接使用objMeeting.ProposedStartTime获取提议时间。
2. 空值处理：将strNewTimeProposed的类型改为Variant，并添加IsEmpty检查，避免无提议时间时的异常。
3. 变量补全：补充声明objWorksheet变量，符合VBA规范。
4. 日期格式优化：将Restrict方法的日期筛选格式改为yyyy-mm-dd hh:mm:ss，避免不同区域设置导致的筛选失效问题。
5. 代码可读性：拆分过长的条件判断行，提升代码易读性。

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