Excel - Outlook
Option Explicit
Sub ListAppointments()
Dim olApp As Object
Dim olNS As Object
Dim olFolder As Object
Dim olApt As Object
Dim NextRow As Long
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(9) 'olFolderCalendar
Range("A1:D1").Value = Array("Subject", "Start", "End", "Location")
NextRow = 2
For Each olApt In olFolder.Items
Cells(NextRow, "A").Value = olApt.Subject
Cells(NextRow, "B").Value = olApt.Start
Cells(NextRow, "C").Value = olApt.End
Cells(NextRow, "D").Value = olApt.Location
NextRow = NextRow + 1
Next olApt
Set olApt = Nothing
Set olFolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
Columns.AutoFit
End Sub
Option Explicit
' VBA Script that gets list of Outlook Calendar Appointments and their Properties and uses the Property Accessor
' Use Tools->Macro->Security to allow Macros to run, then restart Outlook
' Run Outlook, Press Alt+F11 to open VBA
' Programming by Greg Thatcher, http://www.GregThatcher.com
' See http://www.GregThatcher.com for other ways to get the properties of Appointments
Public Sub GetListOfAppointmentsUsingPropertyAccessor()
On Error GoTo On_Error
Dim Session As Outlook.NameSpace
Dim Report As String
Dim AppointmentsFolder As Outlook.Folder
Dim currentItem As Object
Dim currentAppointment As AppointmentItem
Set Session = Application.Session
Set AppointmentsFolder = Session.GetDefaultFolder(olFolderCalendar)
For Each currentItem In AppointmentsFolder.Items
If (currentItem.Class = olAppointment) Then
Set currentAppointment = currentItem
'Call AddToReportIfNotBlank(Report, "Actions", currentAppointment.Actions)
Call AddToReportIfNotBlank(Report, "AllDayEvent", currentAppointment.AllDayEvent)
' Call AddToReportIfNotBlank(Report, "Attachments", currentAppointment.Attachments)
Call AddToReportIfNotBlank(Report, "AutoResolvedWinner", currentAppointment.AutoResolvedWinner)
Call AddToReportIfNotBlank(Report, "BillingInformation", currentAppointment.BillingInformation)
Call AddToReportIfNotBlank(Report, "Body", currentAppointment.Body)
Call AddToReportIfNotBlank(Report, "BusyStatus", currentAppointment.BusyStatus)
Call AddToReportIfNotBlank(Report, "Categories", currentAppointment.Categories)
Call AddToReportIfNotBlank(Report, "Class", currentAppointment.Class)
Call AddToReportIfNotBlank(Report, "Companies", currentAppointment.Companies)
' Call AddToReportIfNotBlank(Report, "Conflicts", currentAppointment.Conflicts)
' Call AddToReportIfNotBlank(Report, "ConversationID", currentAppointment.ConversationID)
Call AddToReportIfNotBlank(Report, "ConversationIndex", currentAppointment.ConversationIndex)
Call AddToReportIfNotBlank(Report, "ConversationTopic", currentAppointment.ConversationTopic)
Call AddToReportIfNotBlank(Report, "CreationTime", currentAppointment.CreationTime)
Call AddToReportIfNotBlank(Report, "DownloadState", currentAppointment.DownloadState)
Call AddToReportIfNotBlank(Report, "Duration", currentAppointment.Duration)
Call AddToReportIfNotBlank(Report, "End", currentAppointment.End)
Call AddToReportIfNotBlank(Report, "EndInEndTimeZone", currentAppointment.EndInEndTimeZone)
Call AddToReportIfNotBlank(Report, "EndTimeZone", currentAppointment.EndTimeZone)
Call AddToReportIfNotBlank(Report, "EndUTC", currentAppointment.EndUTC)
Call AddToReportIfNotBlank(Report, "EntryID", currentAppointment.EntryID)
Call AddToReportIfNotBlank(Report, "ForceUpdateToAllAttendees", currentAppointment.ForceUpdateToAllAttendees)
Call AddToReportIfNotBlank(Report, "FormDescription", currentAppointment.FormDescription)
Call AddToReportIfNotBlank(Report, "GlobalAppointmentID", currentAppointment.GlobalAppointmentID)
Call AddToReportIfNotBlank(Report, "Importance", currentAppointment.Importance)
Call AddToReportIfNotBlank(Report, "InternetCodepage", currentAppointment.InternetCodepage)
Call AddToReportIfNotBlank(Report, "IsConflict", currentAppointment.IsConflict)
Call AddToReportIfNotBlank(Report, "IsRecurring", currentAppointment.IsRecurring)
' Call AddToReportIfNotBlank(Report, "ItemProperties", currentAppointment.ItemProperties)
Call AddToReportIfNotBlank(Report, "LastModificationTime", currentAppointment.LastModificationTime)
' Call AddToReportIfNotBlank(Report, "Links", currentAppointment.Links)
Call AddToReportIfNotBlank(Report, "Location", currentAppointment.Location)
Call AddToReportIfNotBlank(Report, "MarkForDownload", currentAppointment.MarkForDownload)
Call AddToReportIfNotBlank(Report, "MeetingStatus", currentAppointment.MeetingStatus)
Call AddToReportIfNotBlank(Report, "MeetingWorkspaceURL", currentAppointment.MeetingWorkspaceURL)
Call AddToReportIfNotBlank(Report, "MessageClass", currentAppointment.MessageClass)
Call AddToReportIfNotBlank(Report, "Mileage", currentAppointment.Mileage)
Call AddToReportIfNotBlank(Report, "NoAging", currentAppointment.NoAging)
Call AddToReportIfNotBlank(Report, "OptionalAttendees", currentAppointment.OptionalAttendees)
Call AddToReportIfNotBlank(Report, "Organizer", currentAppointment.Organizer)
Call AddToReportIfNotBlank(Report, "OutlookInternalVersion", currentAppointment.OutlookInternalVersion)
Call AddToReportIfNotBlank(Report, "OutlookVersion", currentAppointment.OutlookVersion)
' Call AddToReportIfNotBlank(Report, "Recipients", currentAppointment.Recipients)
Call AddToReportIfNotBlank(Report, "RecurrenceState", currentAppointment.RecurrenceState)
Call AddToReportIfNotBlank(Report, "ReminderMinutesBeforeStart", currentAppointment.ReminderMinutesBeforeStart)
Call AddToReportIfNotBlank(Report, "ReminderOverrideDefault", currentAppointment.ReminderOverrideDefault)
Call AddToReportIfNotBlank(Report, "ReminderPlaySound", currentAppointment.ReminderPlaySound)
Call AddToReportIfNotBlank(Report, "ReminderSet", currentAppointment.ReminderSet)
Call AddToReportIfNotBlank(Report, "ReminderSoundFile", currentAppointment.ReminderSoundFile)
Call AddToReportIfNotBlank(Report, "ReplyTime", currentAppointment.ReplyTime)
Call AddToReportIfNotBlank(Report, "RequiredAttendees", currentAppointment.RequiredAttendees)
Call AddToReportIfNotBlank(Report, "Resources", currentAppointment.Resources)
Call AddToReportIfNotBlank(Report, "ResponseRequested", currentAppointment.ResponseRequested)
Call AddToReportIfNotBlank(Report, "ResponseStatus", currentAppointment.ResponseStatus)
' Call AddToReportIfNotBlank(Report, "RTFBody", currentAppointment.RTFBody)
Call AddToReportIfNotBlank(Report, "Saved", currentAppointment.Saved)
' Call AddToReportIfNotBlank(Report, "SendUsingAccount", currentAppointment.SendUsingAccount)
Call AddToReportIfNotBlank(Report, "Sensitivity", currentAppointment.Sensitivity)
Call AddToReportIfNotBlank(Report, "Size", currentAppointment.Size)
Call AddToReportIfNotBlank(Report, "Start", currentAppointment.Start)
Call AddToReportIfNotBlank(Report, "StartTimeZone", currentAppointment.StartTimeZone)
Call AddToReportIfNotBlank(Report, "StartUTC", currentAppointment.StartUTC)
Call AddToReportIfNotBlank(Report, "Subject", currentAppointment.Subject)
Call AddToReportIfNotBlank(Report, "UnRead", currentAppointment.UnRead)
' Call AddToReportIfNotBlank(Report, "UserProperties", currentAppointment.UserProperties)
Report = Report & "--------------------------------------------------------------------------------------------------------"
Report = Report & vbCrLf & vbCrLf
End If
Next
Call CreateReportAsEmail("List of Appointments", Report)
Exiting:
Exit Sub
On_Error:
MsgBox "error=" & Err.Number & " " & Err.Description
Resume Exiting
End Sub
Private Function AddToReportIfNotBlank(Report As String, FieldName As String, FieldValue)
AddToReportIfNotBlank = ""
If (IsNull(FieldValue) Or FieldValue <> "") Then
AddToReportIfNotBlank = FieldName & " : " & FieldValue & vbCrLf
Report = Report & AddToReportIfNotBlank
End If
End Function
' VBA SubRoutine which displays a report inside an email
' Programming by Greg Thatcher, http://www.GregThatcher.com
Public Sub CreateReportAsEmail(Title As String, Report As String)
On Error GoTo On_Error
Dim Session As Outlook.NameSpace
Dim mail As MailItem
Dim MyAddress As addressEntry
Dim Inbox As Outlook.Folder
Set Session = Application.Session
Set Inbox = Session.GetDefaultFolder(olFolderInbox)
Set mail = Inbox.Items.Add("IPM.Mail")
Set MyAddress = Session.CurrentUser.addressEntry
mail.Recipients.Add (MyAddress.Address)
mail.Recipients.ResolveAll
mail.Subject = Title
mail.Body = Report
mail.Save
mail.Display
Exiting:
Set Session = Nothing
Exit Sub
On_Error:
MsgBox "error=" & Err.Number & " " & Err.Description
Resume Exiting
End Sub
Sub InspectAppointment()
Dim Session As Outlook.NameSpace
Dim Report As String
Dim AppointmentsFolder As Outlook.Folder
Dim currentItem As Object
Dim currentAppointment As AppointmentItem
Set Session = Application.Session
Set AppointmentsFolder = Session.GetDefaultFolder(olFolderCalendar)
For Each currentItem In AppointmentsFolder.Items
If (currentItem.Class = olAppointment) Then
'"Watch" currentAppointment to see what info a appointment Item stores
Set currentAppointment = currentItem
End If
Next
End Sub