This code began it's life in a macro that created a list of Meeting Attendees and Responses. With a few tweaks, the macro creates a new email message addressed to the invitees who have not yet responded.
This can be tweaked to send messages addressed to those who accepted, are tentative, or declined by changing the 0 in this line: If objAttendees(x).MeetingResponseStatus = 0 Then to the constant representing another response type.
In Outlook VBA, valid response statuses are:
Create a message addressed to attendees
- Press Alt+F11 to open the VBA editor.
- Right click on Project1 and choose Insert > Module.
- Paste the code below into the Module.
- Get the GetCurrentItem function from Outlook VBA: work with open item or selected item and paste it at the end of the module.
If location and attendees fields are not picked up when the macro runs against a selected meeting, open the meeting and run it.
To use, select a meeting on the calendar or open a meeting and run the macro. A new message will open, addressed to all invitees (required, optional, or resource) that has not yet responded. The organizer is not included in the message.
Sub SendEmailtoNoRepsonse() Dim objApp As Outlook.Application Dim objItem As Object Dim objAttendees As Outlook.Recipients Dim objAttendeeReq As String Dim objOrganizer As String Dim dtStart As Date Dim dtEnd As Date Dim strSubject As String Dim strLocation As String Dim strMeetStatus As String Dim strCopyData As String On Error Resume Next Set objApp = CreateObject("Outlook.Application") Set objItem = GetCurrentItem() Set objAttendees = objItem.Recipients ' Is it an appointment If objItem.Class <> 26 Then MsgBox "This only works with meetings." GoTo EndClean: End If ' Get the data dtStart = objItem.Start dtEnd = objItem.End strSubject = objItem.Subject strLocation = objItem.Location objOrganizer = objItem.Organizer objAttendeeReq = "" ' Get The Attendee List For x = 1 To objAttendees.Count ' 0 = no response, 2 = tentative, 3 = accepted, 4 = declined, If objAttendees(x).MeetingResponseStatus = 0 Then If objAttendees(x) <> objItem.Organizer Then objAttendeeReq = objAttendeeReq & "; " & objAttendees(x).Address End If End If Next strCopyData = vbCrLf & "-----Original Appointment-----" & vbCrLf & _ "Organizer: " & objOrganizer & vbCrLf & "Subject: " & strSubject & _ vbCrLf & "Where: " & strLocation & vbCrLf & "When: " & _ dtStart & vbCrLf & "Ends: " & dtEnd Dim objOutlookRecip As Outlook.Recipient Set listattendees = Application.CreateItem(olMailItem) listattendees.Body = strCopyData listattendees.Subject = "Please respond to: " & strSubject listattendees.To = objAttendeeReq For Each objOutlookRecip In listattendees.Recipients objOutlookRecip.Resolve Next listattendees.Display EndClean: Set objApp = Nothing Set objItem = Nothing Set objAttendees = Nothing End Sub
Remove invitees who declined
This variation of the macro from J. Frohberg above will remove all person's who declined the meeting. It checks all meetings in the Calendar.
Sub Delete_All_Declined() Dim oOL As New Outlook.Application Dim oNS As Outlook.NameSpace Dim objItem As Outlook.AppointmentItem Set oOL = CreateObject("Outlook.Application") Set oNS = oOL.GetNamespace("MAPI") Set oAppointments = oNS.GetDefaultFolder(olFolderCalendar) For Each objItem In oAppointments.Items On Error Resume Next x = 1 Do Until x > objItem.Recipients.Count ' 0 = no response, 2 = tentative, 3 = accepted, 4 = declined, If objItem.Recipients(x).MeetingResponseStatus = 4 Then If objItem.Recipients(x) objItem.Organizer Then objItem.Recipients(x).Delete x = x - 1 objItem.Save End If End If x = x + 1 Loop Next MsgBox "Done" Set oAppointmentItem = Nothing Set oAppointments = Nothing Set oNS = Nothing Set oOL = Nothing Set objItem = Nothing End Sub