如何返回MeetingResponseStatus?

Question

我想提取团队提出的新的会议时间。

If objMeeting.MeetingResponseStatus = olResponseAccepted Then

说

对象不支持此属性或方法。

我看到了ObjMeeting的所有属性，这是如此有限:

(应用程序
类
会话
父类
动作
附件
BillingInformation
正文
类别
公司
ConversationIndex
ConversationTopic
createtime
EntryID
FormDescription
GetInspector
重要性
LastModificationTime
MessageClass
Mileage
OutlookInternalVersion
OutlookVersion
已保存
敏感性
未读
主题
UserProperties
AutoForwarded
DeferredDeliveryTime
DeleteAfterSubmit
ExpiryTime
OriginatorDeliveryReportRequested
ReceivedTime
收件人
ReminderSet
ReminderTime
reply收件人
SaveSentMessageFolder
sendname
Sent
SentOn
Submitted
DownloadState
ItemProperties
MarkForDownload
IsConflict
MeetingWorkspaceURLAutoResolvedWinner
Conflicts
SenderEmailAddress
SenderEmailType
PropertyAccessor
ConversationID
SendUsingAccount
IsLatestVersion
RTFBody
RetentionPolicyName
BodyFormat
SchedulingServiceMeetingOptionsUrl
SkypeTeamsMeetingETag
skypeteamteamsmeetingurl
skypeteamteamsproperties
TeamsVtcConferenceId
TeamsVtcTenantId)

我找不到提议的时间。

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 Date
Dim objWorkbook As Excel.Workbook
Dim objMeeting As Outlook.MeetingItem
Dim objItem As Object

Dim lngRow As Long

Set Base = ActiveWorkbook

'Define o namespace e a pasta da caixa de entrada
Set objNamespace = Outlook.Application.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)

'Abre o arquivo existente
Set objWorkbook = Workbooks.Open("C:UsersgenascimDesktopGregory ProjectGregory_database.xlsx")

'Verifica se a planilha "New Time Proposed" já existe e cria uma nova planilha com um nome diferente, se necessário
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

'Adiciona a nova planilha e define a primeira linha como cabeçalho
Set objWorksheet = objWorkbook.Sheets.Add(After:=objWorkbook.Sheets(objWorkbook.Sheets.Count))
objWorksheet.Name = strSheetName
objWorksheet.Cells(1, 1).Value = "Remetente"
objWorksheet.Cells(1, 2).Value = "Nova hora proposta"

Set objMailItems = objFolder.Items.Restrict("[ReceivedTime] > '" & Format(Date - 7, "ddddd h:nn AMPM") & "'")

'Loop através dos itens da pasta da caixa de entrada
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
'Check if the email item is a meeting request
If objMeeting.MeetingResponseStatus = olResponseAccepted Then
'Check if the response contains a new time proposal
If objMeeting.MeetingStatus = olMeetingReceivedAndCanceled Or objMeeting.MeetingStatus = olMeetingReceivedAndDeclined Or objMeeting.MeetingStatus = olMeetingReceived Then
If InStr(1, objMeeting.Body, "new time proposed", vbTextCompare) > 0 Then
'Extract the new time proposed
strNewTimeProposed = objMeeting.GetAssociatedAppointment(True).Start
'Add the sender and new time proposed to the worksheet
lngRow = objWorksheet.Cells(objWorksheet.Rows.Count, 1).End(xlUp).Row + 1
objWorksheet.Cells(lngRow, 1).Value = objMail.SenderName
objWorksheet.Cells(lngRow, 2).Value = strNewTimeProposed
End If
End If
End If
End If
Next objItem

'Salva o livro
objWorkbook.Save

End Sub

I tried.StartandStarUTCb.

Answer 1

MeetingResponseStatus是receiver对象的属性，而不是AppointmentItem或MeetingItem。

如果你有一个MeetingItem对象，使用MeetingItem.GetAssociatedAppointment检索相应的AppointmentItem对象，然后使用AppointmentItem.ResponseStatus属性。