Export all Outlook Calendar detz to Excel by Month/Year

[vusi_dube]

Hi All,

I'd like to export all my Outlook scheduled meetings into excel. The output must include the Meeting Name, Name/s of attendees, Email addresses, Attende responses to invite (Accepted/ No Response/ Declined), Required (Required / Optional), Date & Time of meetings. The code below only does this per meeting or calendar event instead of all of my Calendar events for the Month.





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


Thanks inadvance

 

[vusi_dube]

Seriously no one?!