Recently I was planning an event using my Outlook calendar at work. I needed to share the list of users who had accepted the outlook invitation with my fellow event planners. Unfortunately I couldn't find a way to do this in outlook without taking screen shots of the list
I found a website where someone had written a macro to export the list in word.
http://www.outlookcode.com/codedetail.aspx?id=37
The code didn't work in Office 2007 so I tweaked it and decided to take it one step further. I set it to export my list to Excel, instead of word, where I could quickly sort by name or acceptance.
If you have never created a macro before this may be a little intimidating but here's some easy instructions I got from Google Groups
- Copy the code below
- Open Outlook
- Press your <ALT>+<F11> (This opens the Microsoft Visual Basic - VbaProject.OTM)
- On the menu across the top select "Insert"
- Select "Module"
- In the blank window on the right, PASTE the code you copied
- Select "File"
- Select "Close and Return to Microsoft Outlook"
- Right click on your Tool menu (in the gray part where the buttons are)
- Select "Customize..."
- Click on the "Commands" tab
- Select "Macros" from the Categories
- Click on "Project1.PrintAapptAttendee" and drag it to your toolbar
and Drop it (You have to drop it ON the toolbar not in the gray
blank area but next to something like the yellow question mark icon)
- Close the Customize window.
Now try to use this "Macro"
- Open an appointment that has attendees in it
- Click on the "Project1.PrintAapptAttendee" button that you put on your toolbar.
- Wait a moment for Word to open and show you your appointment with all of the attendees and how they responded to the invitation
Code:
Sub PrintAapptAttendee()
' Gather data from an opened appointment and print to
' Excel. 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 objAttendeeReq As String
Dim objAttendeeOpt As String
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 Excel
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.Workbooks.Add
'Create the header and set the background color as yellow
objExcel.Cells(1, 1).Value = "Attendee"
objExcel.Cells(1, 1).Interior.ColorIndex = 6
objExcel.Cells(1, 2).Value = "Response"
objExcel.Cells(1, 2).Interior.ColorIndex = 6
objExcel.Cells(1, 3).Value = "Req/Opt"
objExcel.Cells(1, 3).Interior.ColorIndex = 6
On Error Resume Next
Set objApp = CreateObject("Outlook.Application")
Set objItem = objApp.ActiveInspector.CurrentItem
Set objSelection = objApp.ActiveExplorer.Selection
Set objAttendees = objItem.Recipients
Set objExcel = GetObject(, "Excel.Application")
If objExcel Is Nothing Then
Set objExcel = CreateObject("Excel.Application")
End If
strUnderline = String(60, "_") ' use 60 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 opten the appointment to print."
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 = ""
' Get The Attendee List
For x = 1 To objAttendees.Count
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
objExcel.Cells(x + 1, 1).Value = objAttendees(x).Name
objExcel.Cells(x + 1, 2).Value = strMeetStatus
objExcel.Cells(x + 1, 3).Value = "Required"
Else
objExcel.Cells(x + 1, 1).Value = objAttendees(x).Name
objExcel.Cells(x + 1, 2).Value = strMeetStatus
objExcel.Cells(x + 1, 3).Value = "Optional"
End If
RowCount = RowCount + 1
Next
'Sort Worksheet
objExcel.Worksheets("Sheet1").Range("B2").Sort _
Key1:=objExcel.Worksheets("Sheet1").Columns("B"), _
Header:=xlGuess
objExcel.Worksheets("Sheet1").Range("A2").Sort _
Key1:=objExcel.Worksheets("Sheet1").Columns("B"), _
Header:=xlGuess
objExcel.Worksheets("Sheet1").Range("C2").Sort _
Key1:=objExcel.Worksheets("Sheet1").Columns("B"), _
Header:=xlGuess
EndClean:
Set objApp = Nothing
Set objItem = Nothing
Set objSelection = Nothing
Set objAttendees = Nothing
Set objExcel = Nothing
Set objxls = Nothing
Set excelRng = Nothing
Set wordPara = Nothing
End Sub
---->UPDATE (9/19/08): Please note you are using this macro at your own risk.
Many people were complaining that they could only run the item once and then it stopped working. I did some research and it turn outs that Outlook disables all "untrusted" Macros.
To get this to run more than once you will need to go to:
Tools > Trust Center and Macro Security > and change the radio button to "Warning for all macros"
You will need to close outlook completely (make sure it's not running as a background task) then reopen it.
You will receive a warning each time you run this macro but it should still work.
Download my modified version
