Count the number of scheduling each appointment

[shir0206]

I would like to know how many times I re-schedule an appointment. I use Microsoft Outlook, and many times I have to postpone meetings, I would like to count the number of these postponements.
To achieve that goal, I would like to build a macro that runs through all my "Sent" items, get all the appointments that I've scheduled. Then, create an excel file that contains for each appointment these details: Organizer, Subject, Sent time, Start time, Location, Require Attendees, Optional Attendees, Attendee Response (If possible?). Later on I could analyze that report.
Could anyone help me - What is the best way to do so? I am a programmer but not familiar very well with office macro's syntax. I have found some similar codes online, but couldn't make it work on office 2010+2013.
Thank you all! :-)

[Kenneth Hobs]

The Sent folder varies depending on if on Exchange or not. I commented the default way but used the more elaborate method to set the folder for an account.

Run Main() with a blank sheet active. Some property values are limited to just the item in your Sent folder. e.g. ResponseStatus which is just for your response.

First off, here is the Main() routine. The 2nd code block shows how to get the string for your Sent folder or any Outlook folder. Be sure to add the Outlook reference as I commented.


Sub Main()
Dim a, b
'Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
Dim oApp As Outlook.Application
Dim oG As Outlook.Folder 'Method for IMAP, as used by Gmail.
Dim oM As Outlook.MeetingItem, oAA As Outlook.AppointmentItem
Dim sMsg$, sAdd$, i As Long, j As Long
'Late Binding:
'Dim oApp As Object, oG As Object

Set oApp = CreateObject("Outlook.Application")
'Set oG = oNS.GetDefaultFolder(5) 'olFolderSentMail=5
'Set oG = GetFolderPath("\\ken@gmail.com\[Gmail]\Sent Mail", oApp)
Set oG = GetFolderPath("\\ken@school.edu\Sent Items", oApp)

For i = 1 To oG.Items.Count
'Debug.Print i, TypeName(oG.Items(i))
If TypeName(oG.Items(i)) = "MeetingItem" Then j = j + 1
Next i
If j = 0 Then Exit Sub
ReDim a(1 To j, 1 To 8)

On Error Resume Next
j = 0
For i = 1 To oG.Items.Count
If TypeName(oG.Items(i)) = "MeetingItem" Then
'Set oM = oG.Items(i) 'Let's you use itellisense whereas oG.Items(i) does not.
'Set oAA = oG.Items(i).GetAssociatedAppointment(False)
'With oAA
With oG.Items(i).GetAssociatedAppointment(False)
j = j + 1
a(j, 1) = .Organizer 'Could error if no orgnaizer
a(j, 2) = .Subject
'a(j, 3) = oM.ReceivedTime
a(j, 3) = .CreationTime
a(j, 4) = .Start
a(j, 5) = .Location
a(j, 6) = .RequiredAttendees
a(j, 7) = .OptionalAttendees
'https://docs.microsoft.com/en-us/office/vba/api/outlook.olresponsestatus
a(j, 8) = .ResponseStatus
End With
End If
Next i
On Error GoTo 0


'Title in row 1.
b = Split("Oraganizer,Subject,CreationTime,Start,Location,RequiredAddttendees,Optional Attendees,ResponseStatus", ",")
[A1].Resize(, UBound(b) + 1) = b

'Data from Outlook Sent folder's MeetingItem properties.
'Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(a), UBound(a, 2)).Value = a
[A2].Resize(UBound(a), UBound(a, 2)).Value = a

ActiveSheet.UsedRange.EntireColumn.AutoFit
[A1].Select
End Sub


If you use the Default folder, you won't need this. The first routine let's you pick an Outlook folder to get the string for the 2nd function that was called in Main().


'Get the FolderPath string to pass to GetFolderPath().
Sub GetFolder()
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder


Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.PickFolder

Debug.Print olFolder.FolderPath
MsgBox olFolder.FolderPath
End Sub




'IMAP, folder path, https://www.slipstick.com/outlook/outlook-2013-imap-folder/


'Similar to, http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/#GetFolderPath
''Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
Function GetFolderPath(ByVal FolderPath As String, oApp As Outlook.Application) As Outlook.Folder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer

On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
'Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
Set oFolder = oApp.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function

GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function

[shir0206]

The Sent folder varies depending on if on Exchange or not. I commented the default way but used the more elaborate method to set the folder for an account.

Run Main() with a blank sheet active. Some property values are limited to just the item in your Sent folder. e.g. ResponseStatus which is just for your response.

First off, here is the Main() routine. The 2nd code block shows how to get the string for your Sent folder or any Outlook folder. Be sure to add the Outlook reference as I commented...


Wow! You're the best! Thank you very much!!! :)
I've read the code and run it, and it works perfectly :)
However I have 2 questions about it:


The "Start" parameter displays for each postponed appointment the current start time of the appointment, instead of the start time that was set originally when that appointment was sent ("When" parameter).
For example, if I set an appointment to 01/01/2019 and then postpone it to 02/01/2019 - In the report, in both lines of that appointment, the "Start" cell displays "02/01/2019", instead of "01/01/2019" and "02/01/2019". I've looked over Microsoft documentary, and tried to find that object on my own, but couldn't find the correct one. Is there any way to get the information of "When" parameter?
Is there any way to display a list of the attendees response for each appointment that I sent? Maybe by getting that info from another folder in Outlook (perhaps Inbox)? So later on I could cross that information with the current report).


Thank you

[Kenneth Hobs]

There are three objects that I defined so you could easily use Intellisense to find the methods and properties. Those were oG, oM, and oAA. Just type those objects in the routine and a period to see the methods and properties.

Here is an example that shows when the email was sent. The first uses intellisense providing that the object was Set earlier. The 2nd part shows the same but no Intellisense.


Debug.Print oM.SentOn, oG.Items(i).SentOn

Debug.Print simply puts the results in the VBE Immediate Window during the run.

For (2), one way would be to save the response from each. Consider making a folder and apply an Outlook rule that moves them from InBox folder to your made calendar response folder. You would then get the ResponseStatus value in a macro.

I am not sure what you mean in (1). If a start time was changed, there would be no record of what original start time was after the change.

I forgot to set the Set object to Nothing in Main(). Normally, that is not needed but for this, you should add those. Normally, one sets those to Nothing in reverse order of creation. e.g.

Sub Main()
Dim a, b
'Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
Dim oApp As Outlook.Application
Dim oG As Outlook.Folder 'Method for IMAP, as used by Gmail.
Dim oM As Outlook.MeetingItem, oAA As Outlook.AppointmentItem
Dim sMsg$, sAdd$, i As Long, j As Long
'Late Binding:
'Dim oApp As Object, oG As Object

Set oApp = CreateObject("Outlook.Application")
'Set oG = oNS.GetDefaultFolder(5) 'olFolderSentMail=5
'Set oG = GetFolderPath("\\ken@gmail.com\[Gmail]\Sent Mail", oApp)
Set oG = GetFolderPath("\\ken@school.edu\Sent Items", oApp)

For i = 1 To oG.Items.Count
'Debug.Print i, TypeName(oG.Items(i))
If TypeName(oG.Items(i)) = "MeetingItem" Then j = j + 1
Next i
If j = 0 Then Exit Sub
ReDim a(1 To j, 1 To 8)

On Error Resume Next
j = 0
For i = 1 To oG.Items.Count
If TypeName(oG.Items(i)) = "MeetingItem" Then
'Set oM = oG.Items(i) 'Let's you use itellisense whereas oG.Items(i) does not.
'Set oAA = oG.Items(i).GetAssociatedAppointment(False)
'With oAA
With oG.Items(i).GetAssociatedAppointment(False)
j = j + 1
a(j, 1) = .Organizer 'Could error if no orgnaizer
a(j, 2) = .Subject
'a(j, 3) = oM.ReceivedTime
'Debug.Print oM.SentOn, oG.Items(i).SentOn
a(j, 3) = .CreationTime
a(j, 4) = .Start
a(j, 5) = .Location
a(j, 6) = .RequiredAttendees
a(j, 7) = .OptionalAttendees
'https://docs.microsoft.com/en-us/office/vba/api/outlook.olresponsestatus
a(j, 8) = .ResponseStatus
End With
End If
Next i
On Error GoTo 0


'Title in row 1.
b = Split("Oraganizer,Subject,CreationTime,Start,Location,RequiredAddttendees,Optional Attendees,ResponseStatus", ",")
[A1].Resize(, UBound(b) + 1) = b

'Data from Outlook Sent folder's MeetingItem properties.
'Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(a), UBound(a, 2)).Value = a
[A2].Resize(UBound(a), UBound(a, 2)).Value = a

ActiveSheet.UsedRange.EntireColumn.AutoFit
[A1].Select

Set oAA = Nothing
Set oM = Nothing
Set oG = Nothing
Set oApp = Nothing
End Sub


Lastly, you might want to search for the appointments in this way rather than Folder items.

https://docs.microsoft.com/en-us/office/vba/outlook/how-to/search-and-filter/search-the-calendar-for-appointments-within-a-date-range-that-contain-a-specific

[shir0206]

Thank you very much :)

During the loop I would also like to print the object Outlook>>RecurrencePattern>>StartTime, in order to receive the first date and time of a recurring Calendar item.
How can I access to that variable? I don't get any result if I add the command:
a(j,9) = Outlook.RecurrencePattern.StartTime

Hopefully you would understand my meaning, if not, take a look here in line "Recurrence Range Start"
https://docs.microsoft.com/en-us/office/vba/outlook/concepts/forms/standard-fields-overview

Thank you :)