Vba 在Outlook中添加其他会议之前，如何计算会议参与者的人数

在添加并发送会议之前，我如何计算会议的参与者总数

我已经成功地根据特定的响应自动处理日历邀请

现在，我需要设置最大参与者数量，如果已达到该会议或活动的最大参与者数量，则需要通过邮件回复

如果我检查值，它似乎保持在1

这是我在没有寻求帮助的情况下所能做到的

Private Sub objNewMailItems_ItemAdd(ByVal Item As Object)


Dim objMeetingInvitation As Outlook.MeetingItem
Dim objMeeting As Outlook.AppointmentItem
Dim objAttendees As Outlook.Recipients
Dim objAttendee As Outlook.Recipient
Dim lRequiredAttendeeCount, lOptionalAttendeeCount, lResourceCount As Long
Dim strMsg As String
Dim nPrompt As Integer


On Error Resume Next

Dim olMailItem As MailItem
Dim strAttachementName As String
Dim oRespond As Outlook.MailItem
Dim mesgBody As String
Dim oApp As Outlook.Application
Dim oCalFolder As Outlook.MAPIFolder
Dim oAppt As Outlook.AppointmentItem
Dim sOldText As String
Dim sNewText As String
Dim iCalChangedCount As Integer
Dim mail As Outlook.MailItem
Set oApp = Outlook.Application
Dim nmSpace As Outlook.NameSpace
Set nmSpace = oApp.GetNamespace("MAPI")
Set oCalFolder = nmSpace.GetDefaultFolder(olFolderCalendar)

        If TypeOf Item Is MailItem Then

                    Set olMailItem = Item
                    Set objMeetingInvitation = Item
                    Set objMeeting = objMeetingInvitation.GetAssociatedAppointment(True)
                    Set objAttendees = objMeetingInvitation.Recipients

                    lRequiredAttendeeCount = 0
                    lOptionalAttendeeCount = 0
                    lResourceCount = 0

                   'Count the required & optional attendees and resources, etc.


                    '===============================================================================================================
                    ' Please note...
                    '
                    '   I used mailto:jakes@******.co.za?subject=Yes,%20please%20include%20me&body=I%20would%20like%20to%20join
                    '   as a "mailto:" response
                    '
                    '===============================================================================================================


                        If InStr(olMailItem.Subject, "Testing the Calendar") > 0 Then
                        sOldText = "Test Calendar"

                            For Each objAttendee In objAttendees
                                If objAttendee.Type = olRequired Then
                                   lRequiredAttendeeCount = lRequiredAttendeeCount + 1
                                ElseIf objAttendee.Type = olOptional Then
                                   lOptionalAttendeeCount = lOptionalAttendeeCount + 1
                                ElseIf objAttendee.Type = olResource Then
                                   lResourceCount = lResourceCount + 1
                                End If
                            Next

                            If lRequiredAttendeeCount > 1 Then
                                MsgBox "Attendees on list too many :" & lRequiredAttendeeCount, vbOKOnly
                                Exit Sub
                            End If

                        Do
                            If Not (oCalFolder Is Nothing) Then
                                If (oCalFolder.DefaultItemType = olAppointmentItem) Then Exit Do

                            End If



                            'MsgBox ("Please select a calendar folder from the following list.")
                            'Set oCalFolder = GetDefaultFolder(olFolderCalendar)
                            On Error GoTo ErrHandler:
                                Loop Until oCalFolder.DefaultItemType = olAppointmentItem
                                ' Loop through appointments in calendar, change text where necessary, keep count
                                iCalChangedCount = 0
                            For Each oAppt In oCalFolder.Items
                                If InStr(oAppt.Subject, sOldText) <> 0 Then
                                    Debug.Print "Changed: " & oAppt.Subject & " - " & oAppt.Start
                                    oAppt.Recipients.Add (olMailItem.SenderEmailAddress)
                                    'oAppt.Display
                                    oAppt.Save
                                    oAppt.Send
                                    iCalChangedCount = iCalChangedCount + 1
                                End If
                            Next
                            ' Display results and clear table
                            MsgBox (iCalChangedCount & " appointments have been updated. You have " & lRequiredAttendeeCount & "attendees.")

                        Set oAppt = Nothing
                        Set oCalFolder = Nothing
                        Exit Sub
                        End If


  ErrHandler:
        MsgBox ("Macro terminated.")



                        End If
                    Set Item = Nothing
                    Set olMailItem = Nothing

  End Sub

---

任何想法都将不胜感激

我认为这个问题太宽泛了，至少可以分为三个独立的问题。关注如何计算会议的总参与者，而不包括添加和发送部分

我必须假设您在收到响应时运行代码

Option Explicit

Private Sub objNewMailItems_ItemAdd_Test()
    ' first open up a response to a meeting invitation
    objNewMailItems_ItemAdd ActiveInspector.currentItem
End Sub


Private Sub objNewMailItems_ItemAdd(ByVal Item As Object)

Dim oAppt As AppointmentItem

Dim objAttendees As Recipients
Dim objAttendee As Recipient

Dim lRequiredAttendeeCount As Long
Dim lOptionalAttendeeCount  As Long
Dim lResourceCount As Long

Dim possibleAttendees As Long

Dim limitedAtendees As Long

' For testing purposes
limitedAtendees = InputBox(Prompt:="Enter the maximum number of invitations allowed", Default:="2")

'limitedAtendees = some maximum


' Kiss of death removed
'On Error Resume Next

If TypeOf Item Is MeetingItem Then

    ' Bypass one error only, for a specific purpose
    On Error Resume Next
    Set oAppt = Item.GetAssociatedAppointment(True)
    ' Turn off bypass
    On Error GoTo 0

    If oAppt Is Nothing Then
        MsgBox "No associated appointment found."
        Exit Sub
    End If

    Set objAttendees = oAppt.Recipients
    'Debug.Print objAttendees.count

    lRequiredAttendeeCount = 0
    lOptionalAttendeeCount = 0
    lResourceCount = 0

    'Count the required & optional attendees and resources, etc.

    For Each objAttendee In objAttendees

        'Debug.Print objAttendee

        If objAttendee.Type = olRequired Then
            lRequiredAttendeeCount = lRequiredAttendeeCount + 1
        'ElseIf objAttendee.Type = olOptional Then
        '    lOptionalAttendeeCount = lOptionalAttendeeCount + 1
        'ElseIf objAttendee.Type = olResource Then
        '    lResourceCount = lResourceCount + 1
        End If

    Next

    If lRequiredAttendeeCount > limitedAtendees Then
        MsgBox "Invitations to Required Atendees: " & lRequiredAttendeeCount & vbCr & _
          "This is more than the limit of.......: " & limitedAtendees, vbOKOnly
    Else
        MsgBox "Invitations to Required Atendees: " & lRequiredAttendeeCount & vbCr & _
          "This is within the limit of...........: " & limitedAtendees, vbOKOnly
    End If

    If objAttendees.count > limitedAtendees Then
        MsgBox "Invitations to All Atendees..: " & objAttendees.count & vbCr & _
          "This is more than the limit of: " & limitedAtendees, vbOKOnly
    Else
        MsgBox "Invitations to All Atendees: " & lRequiredAttendeeCount & vbCr & _
          "This is within the limit of....: " & limitedAtendees, vbOKOnly
    End If

End If

ExitRoutine:
    Set oAppt = Nothing

End Sub

编辑2071010

问题中的代码指向邀请数量，但似乎您需要回复数量

Private Sub objNewMailItems_ItemAdd(ByVal Item As Object)

Dim objAppt As AppointmentItem
Dim objAttendee As Recipient

Dim lOrganizerAttendeeCount As Long
Dim lRequiredAttendeeCount As Long
Dim lOptionalAttendeeCount As Long
Dim lResourceCount As Long

Dim attendeeOrganizerNoneCount As Long
Dim attendeeAcceptedCount As Long
Dim attendeeTentativeCount As Long
Dim attendeeDeclinedCount As Long
Dim attendeeNotRespondedCount As Long

Dim invitedAttendees As Long
Dim respondingAttendees As Long

Dim uPrompt As String
Dim uTitle As String

Debug.Print
Debug.Print "Item.Class: " & Item.Class

'  26 - AppointmentItem
'
' Various MeetingItems
'  53 to 57
'  53 - should be the initial invitation
' 181 - Meeting Forward Notification
'  - with no response (0), the invited person counts as a "None" response

If Item.Class = 26 Then
    Set objAppt = Item

' tested
'   olMeetingResponsePositive
'    53
'   181
ElseIf Item.Class = olMeetingResponsePositive Or _
  Item.Class = olMeetingResponseTentative Or _
  Item.Class = olMeetingResponseNegative Or _
  Item.Class = 53 Or _
  Item.Class = 54 Or _
  Item.Class = 55 Or _
  Item.Class = 56 Or _
  Item.Class = 57 Or _
  Item.Class = 181 Then

    ' Bypass errors for a specific purpose
    On Error Resume Next
    Set objAppt = Item.GetAssociatedAppointment(True)
    ' Turn error bypass off
    On Error GoTo 0

    If objAppt Is Nothing Then
        MsgBox "No appointment associated with the meeting response " & _
          vbCr & vbCr & Item.Subject
        Exit Sub
    End If

Else
    MsgBox "Item class " & Item.Class & " not recognized in this code. "
    Exit Sub

End If

For Each objAttendee In objAppt.Recipients

    Debug.Print
    Debug.Print "Invitee name...: " & objAttendee.name

    'Count the invitations

    Debug.Print "Invitation Type: " & objAttendee.Type

    ' https://msdn.microsoft.com/en-us/vba/outlook-vba/articles/olmeetingrecipienttype-enumeration-outlook
    ' 0 = olOrganizer
    ' 1 = olRequired
    ' 2 = olOptional
    ' 3 = olResource

    Select Case objAttendee.Type

        Case 0
            lOrganizerAttendeeCount = lOrganizerAttendeeCount + 1

        Case 1
            lRequiredAttendeeCount = lRequiredAttendeeCount + 1

        Case 2
            lOptionalAttendeeCount = lOptionalAttendeeCount + 1

        Case 3
            lResourceCount = lResourceCount + 1

    End Select

    ' Count the responses

    Debug.Print "Response Status: " & objAttendee.MeetingResponseStatus

    ' https://msdn.microsoft.com/VBA/Outlook-VBA/articles/olresponsestatus-enumeration-outlook
    ' 0 = "None" - This is what I get as the organizer
    ' 1 = "Organized"
    ' 2 = "Tentative"
    ' 3 = "Accepted"
    ' 4 = "Declined"
    ' 5 = "Not Responded"

    Select Case objAttendee.MeetingResponseStatus

        Case 0
             attendeeOrganizerNoneCount = attendeeOrganizerNoneCount + 1

        Case 1
            attendeeOrganizerNoneCount = attendeeOrganizerNoneCount + 1

        Case 2
            attendeeTentativeCount = attendeeTentativeCount + 1

        Case 3
            attendeeAcceptedCount = attendeeAcceptedCount + 1

        Case 4
            attendeeDeclinedCount = attendeeDeclinedCount + 1

        Case 5
            attendeeNotRespondedCount = attendeeNotRespondedCount + 1

    End Select

    Set objAttendee = Nothing

Next

invitedAttendees = lOrganizerAttendeeCount + lRequiredAttendeeCount + _
                    lOptionalAttendeeCount + lResourceCount

respondingAttendees = attendeeOrganizerNoneCount + attendeeAcceptedCount + _
                    attendeeTentativeCount + attendeeDeclinedCount + attendeeNotRespondedCount

' Display results
uTitle = "Attendees for " & objAppt.Subject

uPrompt = "Invitations:" & vbCr & _
  " " & lOrganizerAttendeeCount & " :Organizer" & vbCr & _
  " " & lRequiredAttendeeCount & " :Required" & vbCr & _
  " " & lOptionalAttendeeCount & " :Optional" & vbCr & _
  " " & lResourceCount & " :Resource" & vbCr & _
  " " & invitedAttendees & " : TOTAL" & vbCr & vbCr

uPrompt = uPrompt & " Responses:" & vbCr & _
  " " & attendeeOrganizerNoneCount & " :organizer none" & vbCr & _
  " " & attendeeAcceptedCount & " :accepts" & vbCr & _
  " " & attendeeTentativeCount & " :tentatives" & vbCr & _
  " " & attendeeDeclinedCount & " :declines" & vbCr & _
  " " & attendeeNotRespondedCount & " :no responses" & vbCr & _
  " " & respondingAttendees & " : TOTAL"

    MsgBox Prompt:=uPrompt, Title:=uTitle

ExitRoutine:
    Set objAppt = Nothing
    Set objAttendee = Nothing

End Sub

---

我听到你在说什么了。让我把它从您的解决方案中分解出来，然后分部分进行尝试。现在，我已经将其设置为对文件夹项目进行计数，并设置了一个规则将响应移动到该文件夹中，以便使用宏保持计数并使用模板自动响应。计算与会者人数将是一个更干净的解决方案，也许，如果我足够勇敢的话，我会尝试自动删除取消：-D我会再尝试一次，然后回来。@Jake的回答现在包含了一个回答计数

Private Sub objNewMailItems_ItemAdd(ByVal Item As Object)

Dim objAppt As AppointmentItem
Dim objAttendee As Recipient

Dim lOrganizerAttendeeCount As Long
Dim lRequiredAttendeeCount As Long
Dim lOptionalAttendeeCount As Long
Dim lResourceCount As Long

Dim attendeeOrganizerNoneCount As Long
Dim attendeeAcceptedCount As Long
Dim attendeeTentativeCount As Long
Dim attendeeDeclinedCount As Long
Dim attendeeNotRespondedCount As Long

Dim invitedAttendees As Long
Dim respondingAttendees As Long

Dim uPrompt As String
Dim uTitle As String

Debug.Print
Debug.Print "Item.Class: " & Item.Class

'  26 - AppointmentItem
'
' Various MeetingItems
'  53 to 57
'  53 - should be the initial invitation
' 181 - Meeting Forward Notification
'  - with no response (0), the invited person counts as a "None" response

If Item.Class = 26 Then
    Set objAppt = Item

' tested
'   olMeetingResponsePositive
'    53
'   181
ElseIf Item.Class = olMeetingResponsePositive Or _
  Item.Class = olMeetingResponseTentative Or _
  Item.Class = olMeetingResponseNegative Or _
  Item.Class = 53 Or _
  Item.Class = 54 Or _
  Item.Class = 55 Or _
  Item.Class = 56 Or _
  Item.Class = 57 Or _
  Item.Class = 181 Then

    ' Bypass errors for a specific purpose
    On Error Resume Next
    Set objAppt = Item.GetAssociatedAppointment(True)
    ' Turn error bypass off
    On Error GoTo 0

    If objAppt Is Nothing Then
        MsgBox "No appointment associated with the meeting response " & _
          vbCr & vbCr & Item.Subject
        Exit Sub
    End If

Else
    MsgBox "Item class " & Item.Class & " not recognized in this code. "
    Exit Sub

End If

For Each objAttendee In objAppt.Recipients

    Debug.Print
    Debug.Print "Invitee name...: " & objAttendee.name

    'Count the invitations

    Debug.Print "Invitation Type: " & objAttendee.Type

    ' https://msdn.microsoft.com/en-us/vba/outlook-vba/articles/olmeetingrecipienttype-enumeration-outlook
    ' 0 = olOrganizer
    ' 1 = olRequired
    ' 2 = olOptional
    ' 3 = olResource

    Select Case objAttendee.Type

        Case 0
            lOrganizerAttendeeCount = lOrganizerAttendeeCount + 1

        Case 1
            lRequiredAttendeeCount = lRequiredAttendeeCount + 1

        Case 2
            lOptionalAttendeeCount = lOptionalAttendeeCount + 1

        Case 3
            lResourceCount = lResourceCount + 1

    End Select

    ' Count the responses

    Debug.Print "Response Status: " & objAttendee.MeetingResponseStatus

    ' https://msdn.microsoft.com/VBA/Outlook-VBA/articles/olresponsestatus-enumeration-outlook
    ' 0 = "None" - This is what I get as the organizer
    ' 1 = "Organized"
    ' 2 = "Tentative"
    ' 3 = "Accepted"
    ' 4 = "Declined"
    ' 5 = "Not Responded"

    Select Case objAttendee.MeetingResponseStatus

        Case 0
             attendeeOrganizerNoneCount = attendeeOrganizerNoneCount + 1

        Case 1
            attendeeOrganizerNoneCount = attendeeOrganizerNoneCount + 1

        Case 2
            attendeeTentativeCount = attendeeTentativeCount + 1

        Case 3
            attendeeAcceptedCount = attendeeAcceptedCount + 1

        Case 4
            attendeeDeclinedCount = attendeeDeclinedCount + 1

        Case 5
            attendeeNotRespondedCount = attendeeNotRespondedCount + 1

    End Select

    Set objAttendee = Nothing

Next

invitedAttendees = lOrganizerAttendeeCount + lRequiredAttendeeCount + _
                    lOptionalAttendeeCount + lResourceCount

respondingAttendees = attendeeOrganizerNoneCount + attendeeAcceptedCount + _
                    attendeeTentativeCount + attendeeDeclinedCount + attendeeNotRespondedCount

' Display results
uTitle = "Attendees for " & objAppt.Subject

uPrompt = "Invitations:" & vbCr & _
  " " & lOrganizerAttendeeCount & " :Organizer" & vbCr & _
  " " & lRequiredAttendeeCount & " :Required" & vbCr & _
  " " & lOptionalAttendeeCount & " :Optional" & vbCr & _
  " " & lResourceCount & " :Resource" & vbCr & _
  " " & invitedAttendees & " : TOTAL" & vbCr & vbCr

uPrompt = uPrompt & " Responses:" & vbCr & _
  " " & attendeeOrganizerNoneCount & " :organizer none" & vbCr & _
  " " & attendeeAcceptedCount & " :accepts" & vbCr & _
  " " & attendeeTentativeCount & " :tentatives" & vbCr & _
  " " & attendeeDeclinedCount & " :declines" & vbCr & _
  " " & attendeeNotRespondedCount & " :no responses" & vbCr & _
  " " & respondingAttendees & " : TOTAL"

    MsgBox Prompt:=uPrompt, Title:=uTitle

ExitRoutine:
    Set objAppt = Nothing
    Set objAttendee = Nothing

End Sub