P
Peter646
How do I retrieve the text of meeting responses associated with an appointment?
I have redeveloped a macro which produces a word document listing the
meeting response status of invitees to an appointment. I would like, for
those who declined, to include the body of the meeting response (ie., where
the invitee has chosen to "Edit response before sending." While the Meeting
Response Status is a Recipient property, the text of the response is not.
Any ideas? I'm including the macro below:
Public Sub PrintAttendees()
' Gather data from an opened appointment and print to
' Word. This provides a way to print the attendee list with their
' response, which Outlook will not do on its own.
' Set up Outlook
Dim objApp As Outlook.Application
Dim objItem As Object
Dim objSelection As Selection
Dim objAttendees As Outlook.Recipients
Dim objAttendeeReqNR As String
Dim objAttendeeReqO As String
Dim objAttendeeReqT As String
Dim objAttendeeReqA As String
Dim objAttendeeReqD As String
Dim objAttendeeOptNR As String
Dim objAttendeeOptO As String
Dim objAttendeeOptT As String
Dim objAttendeeOptA As String
Dim objAttendeeOptD As String
Dim countAttendeeNR As Integer
Dim countAttendeeO As Integer
Dim countAttendeeT As Integer
Dim countAttendeeA As Integer
Dim countAttendeeD As Integer
Dim objOrganizer As String
Dim dtStart As Date
Dim dtEnd As Date
Dim strSubject As String
Dim strLocation As String
Dim strNotes As String
Dim strMeetStatus As String
Dim strUnderline As String ' Horizontal divider line
' Set up Word
Dim objWord As Object
Dim objdoc As Object
Dim wordRng As Object
Dim wordPara As Object
On Error Resume Next
Set objApp = CreateObject("Outlook.Application")
Set objItem = objApp.ActiveInspector.CurrentItem
Set objSelection = objApp.ActiveExplorer.Selection
Set objAttendees = objItem.Recipients
Set objWord = GetObject(, "Word.application")
If objWord Is Nothing Then
Set objWord = CreateObject("word.application")
End If
strUnderline = String(50, "_") ' use 50 underline characters
On Error GoTo EndClean:
' check for user problems with none or too many items open
Select Case objSelection.Count
Case 0
MsgBox "No appointment was opened. Please open one appointment."
GoTo EndClean:
Case Is > 1
MsgBox "Too many items were selected. Just select one!!!"
GoTo EndClean:
End Select
' Is it an appointment
If objItem.Class <> 26 Then
MsgBox "You First Need To open The Appointment to Print."
GoTo EndClean:
End If
' Get the data
dtStart = objItem.Start
dtEnd = objItem.End
strSubject = objItem.Subject
strLocation = objItem.Location
strNotes = objItem.Body
objOrganizer = objItem.Organizer
objAttendeeReq = ""
objAttendeeOpt = ""
countAttendeeNR = 0
countAttendeeO = 0
countAttendeeT = 0
countAttendeeA = 0
countAttendeeD = 0
' Get The Attendee List
For x = 1 To objAttendees.Count
If objAttendees(x).Name = strLocation Then
GoTo EndofLoop
End If
strMeetStatus = ""
Select Case objAttendees(x).MeetingResponseStatus
Case 0
strMeetStatus = "No Response"
Case 1
strMeetStatus = "Organizer"
Case 2
strMeetStatus = "Tentative"
Case 3
strMeetStatus = "Accepted"
Case 4
strMeetStatus = "Declined"
End Select
If objAttendees(x).Type = olRequired Then
If objAttendees(x).MeetingResponseStatus = 0 Then
If objAttendees(x).Name = objOrganizer Then
objAttendeeReqO = objAttendeeReqO & objAttendees(x).Name & vbTab
& "Organiser" & vbCr
countAttendeeO = countAttendeeO + 1
Else
objAttendeeReqNR = objAttendeeReqNR & objAttendees(x).Name &
vbTab & strMeetStatus & vbCr
countAttendeeNR = countAttendeeNR + 1
End If
Else
If objAttendees(x).MeetingResponseStatus = 1 Then
objAttendeeReqO = objAttendeeReqO & objAttendees(x).Name & vbTab
& strMeetStatus & vbCr
countAttendeeO = countAttendeeO + 1
Else
If objAttendees(x).MeetingResponseStatus = 2 Then
objAttendeeReqT = objAttendeeReqT & objAttendees(x).Name &
vbTab & strMeetStatus & vbCr
countAttendeeT = countAttendeeT + 1
Else
If objAttendees(x).MeetingResponseStatus = 3 Then
objAttendeeReqA = objAttendeeReqA & objAttendees(x).Name
& vbTab & strMeetStatus & vbCr
countAttendeeA = countAttendeeA + 1
Else
objAttendeeReqD = objAttendeeReqD & objAttendees(x).Name
& vbTab & strMeetStatus & vbCr
countAttendeeD = countAttendeeD + 1
End If
End If
End If
End If
Else
If objAttendees(x).MeetingResponseStatus = 0 Then
objAttendeeOptNR = objAttendeeOptNR & objAttendees(x).Name & vbTab &
strMeetStatus & vbCr
countAttendeeNR = countAttendeeNR + 1
Else
If objAttendees(x).MeetingResponseStatus = 1 Then
objAttendeeOptO = objAttendeeOptO & objAttendees(x).Name & vbTab
& strMeetStatus & vbCr
countAttendeeO = countAttendeeO + 1
Else
If objAttendees(x).MeetingResponseStatus = 2 Then
objAttendeeOptT = objAttendeeOptT & objAttendees(x).Name &
vbTab & strMeetStatus & vbCr
countAttendeeT = countAttendeeT + 1
Else
If objAttendees(x).MeetingResponseStatus = 3 Then
objAttendeeOptA = objAttendeeOptA & objAttendees(x).Name
& vbTab & strMeetStatus & vbCr
countAttendeeA = countAttendeeA + 1
Else
objAttendeeOptD = objAttendeeOptD & objAttendees(x).Name
& vbTab & strMeetStatus & vbCr
countAttendeeD = countAttendeeD + 1
End If
End If
End If
End If
End If
EndofLoop:
Next
' Word: Open a new doc and fill it
objWord.Visible = True
Set objdoc = objWord.Documents.Add
Set objdoc = objWord.ActiveDocument
Set wordRng = objdoc.Range
objdoc.Paragraphs.TabStops.ClearAll
objdoc.Paragraphs.TabStops.Add Position:=180
With wordRng
.Font.Bold = True
.Font.Italic = False
.Font.Size = 14
.InsertAfter "Subject: " & strSubject
.InsertParagraphAfter
.InsertAfter strUnderline
.InsertParagraphAfter
.InsertParagraphAfter
End With
Set wordPara1 = wordRng.Paragraphs(4)
With wordPara1.Range
.Font.Bold = False
.Font.Italic = False
.Font.Size = 12
.InsertAfter "Organiser:" & vbTab & objOrganizer
.InsertParagraphAfter
.InsertAfter "Location:" & vbTab & strLocation
.InsertParagraphAfter
.InsertParagraphAfter
.InsertAfter "Start: " & dtStart
.InsertParagraphAfter
.InsertAfter "End: " & dtEnd
.InsertParagraphAfter
.InsertParagraphAfter
.InsertAfter "Required: "
.InsertParagraphAfter
.InsertAfter objAttendeeReqO
.InsertAfter objAttendeeReqA
.InsertAfter objAttendeeReqT
.InsertAfter objAttendeeReqNR
.InsertAfter objAttendeeReqD
.InsertParagraphAfter
.InsertAfter "Optional: "
.InsertParagraphAfter
.InsertAfter objAttendeeOptO
.InsertAfter objAttendeeOptA
.InsertAfter objAttendeeOptT
.InsertAfter objAttendeeOptNR
.InsertAfter objAttendeeOptD
.InsertParagraphAfter
End With
Set wordPara1a = wordRng.Paragraphs.Last
With wordPara1a.Range
.Font.Size = 12
.InsertAfter "Organiser:" & vbTab & countAttendeeO & vbCr
.InsertAfter "Accepted:" & vbTab & countAttendeeA & vbCr
.InsertAfter "Tentative:" & vbTab & countAttendeeT & vbCr
.InsertAfter "No Response:" & vbTab & countAttendeeNR & vbCr
.InsertAfter "Declined:" & vbTab & countAttendeeD & vbCr
.InsertParagraphAfter
End With
Set wordPara2 = wordRng.Paragraphs.Last
With wordPara2.Range
.Font.Size = 14
.InsertAfter strUnderline & vbCr
.InsertParagraphAfter
.InsertAfter "Notes" & vbCr
.InsertParagraphAfter
End With
Set wordPara3 = wordRng.Paragraphs.Last
With wordPara3.Range
.Font.Size = 12
.InsertAfter strNotes
End With
EndClean:
Set objApp = Nothing
Set objItem = Nothing
Set objSelection = Nothing
Set objAttendees = Nothing
Set objWord = Nothing
Set objdoc = Nothing
Set wordRng = Nothing
Set wordPara = Nothing
End Sub
I have redeveloped a macro which produces a word document listing the
meeting response status of invitees to an appointment. I would like, for
those who declined, to include the body of the meeting response (ie., where
the invitee has chosen to "Edit response before sending." While the Meeting
Response Status is a Recipient property, the text of the response is not.
Any ideas? I'm including the macro below:
Public Sub PrintAttendees()
' Gather data from an opened appointment and print to
' Word. This provides a way to print the attendee list with their
' response, which Outlook will not do on its own.
' Set up Outlook
Dim objApp As Outlook.Application
Dim objItem As Object
Dim objSelection As Selection
Dim objAttendees As Outlook.Recipients
Dim objAttendeeReqNR As String
Dim objAttendeeReqO As String
Dim objAttendeeReqT As String
Dim objAttendeeReqA As String
Dim objAttendeeReqD As String
Dim objAttendeeOptNR As String
Dim objAttendeeOptO As String
Dim objAttendeeOptT As String
Dim objAttendeeOptA As String
Dim objAttendeeOptD As String
Dim countAttendeeNR As Integer
Dim countAttendeeO As Integer
Dim countAttendeeT As Integer
Dim countAttendeeA As Integer
Dim countAttendeeD As Integer
Dim objOrganizer As String
Dim dtStart As Date
Dim dtEnd As Date
Dim strSubject As String
Dim strLocation As String
Dim strNotes As String
Dim strMeetStatus As String
Dim strUnderline As String ' Horizontal divider line
' Set up Word
Dim objWord As Object
Dim objdoc As Object
Dim wordRng As Object
Dim wordPara As Object
On Error Resume Next
Set objApp = CreateObject("Outlook.Application")
Set objItem = objApp.ActiveInspector.CurrentItem
Set objSelection = objApp.ActiveExplorer.Selection
Set objAttendees = objItem.Recipients
Set objWord = GetObject(, "Word.application")
If objWord Is Nothing Then
Set objWord = CreateObject("word.application")
End If
strUnderline = String(50, "_") ' use 50 underline characters
On Error GoTo EndClean:
' check for user problems with none or too many items open
Select Case objSelection.Count
Case 0
MsgBox "No appointment was opened. Please open one appointment."
GoTo EndClean:
Case Is > 1
MsgBox "Too many items were selected. Just select one!!!"
GoTo EndClean:
End Select
' Is it an appointment
If objItem.Class <> 26 Then
MsgBox "You First Need To open The Appointment to Print."
GoTo EndClean:
End If
' Get the data
dtStart = objItem.Start
dtEnd = objItem.End
strSubject = objItem.Subject
strLocation = objItem.Location
strNotes = objItem.Body
objOrganizer = objItem.Organizer
objAttendeeReq = ""
objAttendeeOpt = ""
countAttendeeNR = 0
countAttendeeO = 0
countAttendeeT = 0
countAttendeeA = 0
countAttendeeD = 0
' Get The Attendee List
For x = 1 To objAttendees.Count
If objAttendees(x).Name = strLocation Then
GoTo EndofLoop
End If
strMeetStatus = ""
Select Case objAttendees(x).MeetingResponseStatus
Case 0
strMeetStatus = "No Response"
Case 1
strMeetStatus = "Organizer"
Case 2
strMeetStatus = "Tentative"
Case 3
strMeetStatus = "Accepted"
Case 4
strMeetStatus = "Declined"
End Select
If objAttendees(x).Type = olRequired Then
If objAttendees(x).MeetingResponseStatus = 0 Then
If objAttendees(x).Name = objOrganizer Then
objAttendeeReqO = objAttendeeReqO & objAttendees(x).Name & vbTab
& "Organiser" & vbCr
countAttendeeO = countAttendeeO + 1
Else
objAttendeeReqNR = objAttendeeReqNR & objAttendees(x).Name &
vbTab & strMeetStatus & vbCr
countAttendeeNR = countAttendeeNR + 1
End If
Else
If objAttendees(x).MeetingResponseStatus = 1 Then
objAttendeeReqO = objAttendeeReqO & objAttendees(x).Name & vbTab
& strMeetStatus & vbCr
countAttendeeO = countAttendeeO + 1
Else
If objAttendees(x).MeetingResponseStatus = 2 Then
objAttendeeReqT = objAttendeeReqT & objAttendees(x).Name &
vbTab & strMeetStatus & vbCr
countAttendeeT = countAttendeeT + 1
Else
If objAttendees(x).MeetingResponseStatus = 3 Then
objAttendeeReqA = objAttendeeReqA & objAttendees(x).Name
& vbTab & strMeetStatus & vbCr
countAttendeeA = countAttendeeA + 1
Else
objAttendeeReqD = objAttendeeReqD & objAttendees(x).Name
& vbTab & strMeetStatus & vbCr
countAttendeeD = countAttendeeD + 1
End If
End If
End If
End If
Else
If objAttendees(x).MeetingResponseStatus = 0 Then
objAttendeeOptNR = objAttendeeOptNR & objAttendees(x).Name & vbTab &
strMeetStatus & vbCr
countAttendeeNR = countAttendeeNR + 1
Else
If objAttendees(x).MeetingResponseStatus = 1 Then
objAttendeeOptO = objAttendeeOptO & objAttendees(x).Name & vbTab
& strMeetStatus & vbCr
countAttendeeO = countAttendeeO + 1
Else
If objAttendees(x).MeetingResponseStatus = 2 Then
objAttendeeOptT = objAttendeeOptT & objAttendees(x).Name &
vbTab & strMeetStatus & vbCr
countAttendeeT = countAttendeeT + 1
Else
If objAttendees(x).MeetingResponseStatus = 3 Then
objAttendeeOptA = objAttendeeOptA & objAttendees(x).Name
& vbTab & strMeetStatus & vbCr
countAttendeeA = countAttendeeA + 1
Else
objAttendeeOptD = objAttendeeOptD & objAttendees(x).Name
& vbTab & strMeetStatus & vbCr
countAttendeeD = countAttendeeD + 1
End If
End If
End If
End If
End If
EndofLoop:
Next
' Word: Open a new doc and fill it
objWord.Visible = True
Set objdoc = objWord.Documents.Add
Set objdoc = objWord.ActiveDocument
Set wordRng = objdoc.Range
objdoc.Paragraphs.TabStops.ClearAll
objdoc.Paragraphs.TabStops.Add Position:=180
With wordRng
.Font.Bold = True
.Font.Italic = False
.Font.Size = 14
.InsertAfter "Subject: " & strSubject
.InsertParagraphAfter
.InsertAfter strUnderline
.InsertParagraphAfter
.InsertParagraphAfter
End With
Set wordPara1 = wordRng.Paragraphs(4)
With wordPara1.Range
.Font.Bold = False
.Font.Italic = False
.Font.Size = 12
.InsertAfter "Organiser:" & vbTab & objOrganizer
.InsertParagraphAfter
.InsertAfter "Location:" & vbTab & strLocation
.InsertParagraphAfter
.InsertParagraphAfter
.InsertAfter "Start: " & dtStart
.InsertParagraphAfter
.InsertAfter "End: " & dtEnd
.InsertParagraphAfter
.InsertParagraphAfter
.InsertAfter "Required: "
.InsertParagraphAfter
.InsertAfter objAttendeeReqO
.InsertAfter objAttendeeReqA
.InsertAfter objAttendeeReqT
.InsertAfter objAttendeeReqNR
.InsertAfter objAttendeeReqD
.InsertParagraphAfter
.InsertAfter "Optional: "
.InsertParagraphAfter
.InsertAfter objAttendeeOptO
.InsertAfter objAttendeeOptA
.InsertAfter objAttendeeOptT
.InsertAfter objAttendeeOptNR
.InsertAfter objAttendeeOptD
.InsertParagraphAfter
End With
Set wordPara1a = wordRng.Paragraphs.Last
With wordPara1a.Range
.Font.Size = 12
.InsertAfter "Organiser:" & vbTab & countAttendeeO & vbCr
.InsertAfter "Accepted:" & vbTab & countAttendeeA & vbCr
.InsertAfter "Tentative:" & vbTab & countAttendeeT & vbCr
.InsertAfter "No Response:" & vbTab & countAttendeeNR & vbCr
.InsertAfter "Declined:" & vbTab & countAttendeeD & vbCr
.InsertParagraphAfter
End With
Set wordPara2 = wordRng.Paragraphs.Last
With wordPara2.Range
.Font.Size = 14
.InsertAfter strUnderline & vbCr
.InsertParagraphAfter
.InsertAfter "Notes" & vbCr
.InsertParagraphAfter
End With
Set wordPara3 = wordRng.Paragraphs.Last
With wordPara3.Range
.Font.Size = 12
.InsertAfter strNotes
End With
EndClean:
Set objApp = Nothing
Set objItem = Nothing
Set objSelection = Nothing
Set objAttendees = Nothing
Set objWord = Nothing
Set objdoc = Nothing
Set wordRng = Nothing
Set wordPara = Nothing
End Sub