Extracting a location from a meeting - VBA

[Joshyd]

Hi,

I am not sure if this is possible, but I have a macro that is building onboarding schedules in Word and filling in details based on an excel spreadsheet. The current problem I am having is that the locations of the meetings do change every couple of weeks. These locations are in Outlook meetings. I am wondering if there is a way for VBA to look at the meeting in the calendar (on the next onboarding day), and extract the meeting location to be inserted into the Word document.

Thanks in advance.

Josh

 

[shknbk2]

Short answer: Yes

Not very helpful, I know, but more information would be needed to get to the right appointment. I've copied some code that I've modified from something else I've done that can possibly be a seed to get to the code you need. It will need to be modified based on the "more information" that I don't have. For example, is the standard/main Calendar the correct folder, or is it a Public Folder shared by all? Is the appointmentItem's subject the searching field you want to identify the correct appt from which to get the location? Etc.

Function getLocation() As String
    Dim oApp As Outlook.Application, oCal As Outlook.Folder, appt As Outlook.AppointmentItem
    Dim explorerInstance As Outlook.Explorer, objNS As Outlook.Namespace
    Dim ofldItems As Outlook.Items, sortItems As Outlook.Items
    Dim tdystart As Date, tdyend As Date
    Dim sRestrict As String


    tdystart = DateSerial(Year(Now), Month(Now), Day(Now))
    tdyend = DateSerial(Year(Now), Month(Now), Day(Now) + 1)
    Set oApp = CreateObject("Outlook.application")
    Set objNS = oApp.GetNamespace("MAPI")
    Set oCal = objNS.GetDefaultFolder(olFolderCalendar)
    If oCal Is Nothing Then
        For Each explorerInstance In oApp.Explorers
            If InStr(1, explorerInstance.Caption, "Calendar") > 0 Then
                Set oCal = explorerInstance.CurrentFolder
                Exit For
            End If
        Next
        If oCal Is Nothing Then
            Exit Function
        End If
    End If
    
    Set ofldItems = oCal.Items
    ofldItems.Sort ("[Start]")
    sRestrict = "[Start] >= '" & tdystart & "' and [End] <= '" & tdyend & "'"
    Set sortItems = ofldItems.Restrict(sRestrict)
    sortItems.Sort ("[Subject]")


    For Each appt In sortItems
        If appt.Subject = "THIS IS THE ONE" Then
            getLocation = appt.Location
            Exit For
        End If
    Next appt
 
    Set oApp = Nothing
    Set objNS = Nothing
    Set oCal = Nothing
    Set ofldItems = Nothing
    Set sortItems = Nothing
End Function

You'll need to add a Tools->Reference selection to the MS Outlook Object library.

 

[Joshyd]

thanks, I was able to use your code to get me going. The project fell by the wayside for a bit so I just got to it yesterday. Here is the code if it helps anyone else. It includes contacting a shared calendar.

Function getLocation() As String    Dim oApp As Outlook.Application, oCal As Outlook.Folder, appt As Outlook.AppointmentItem
    Dim explorerInstance As Outlook.Explorer, objNS As Outlook.Namespace
    Dim ofldItems As Outlook.Items, sortItems As Outlook.Items
    Dim tdystart As Date, tdyend As Date
    Dim sRestrict As String
    Dim myRecipient As Outlook.Recipient
    
    


    tdystart = DateSerial(Year(Now), Month(Now), Day(Now))
    tdyend = DateSerial(Year(Range("U4")), Month(Range("U4")), Day(Range("U4")) + 2)
    Set oApp = CreateObject("Outlook.application")
    Set objNS = oApp.GetNamespace("MAPI")
    Set myRecipient = objNS.CreateRecipient("learning")
    myRecipient.Resolve
        
       
    If myRecipient.Resolved Then
        Set oCal = objNS.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
    End If
    


    
    If oCal Is Nothing Then
        For Each explorerInstance In oApp.Explorers
            If InStr(1, explorerInstance.Caption, "Calendar") > 0 Then
                Set oCal = explorerInstance.CurrentFolder
                Exit For
            End If
            
        Next
        If oCal Is Nothing Then
            Exit Function
        End If
    End If
    
    Set ofldItems = oCal.Items
    ofldItems.Sort ("[Start]")
    sRestrict = "[Start] >= '" & tdystart & "' and [End] <= '" & tdyend & "'"
    Set sortItems = ofldItems.Restrict(sRestrict)
    sortItems.Sort ("[Subject]")




    For Each appt In sortItems
        If appt.Subject = "Hold For Onboarding - Matrix Welcome and Office Orientation" Then
            getLocation = appt.location
            Exit For
        End If
    Next appt
    
    MsgBox getLocation
 
    Set oApp = Nothing
    Set objNS = Nothing
    Set oCal = Nothing
    Set ofldItems = Nothing
    Set sortItems = Nothing
End Function

 

[shknbk2]

You're welcome, and thanks for the feedback. Glad you got it working.

 

[Joshyd]

New Problem with this Macro. Not sure if I should open a new thread, but I have got the macro working nicely minus the fact that the appointments I am looking at are recurrences. The macro only refers to the location of the whole series. If the occurrence happens between tdystart and tdyend, and is a different location than the whole series, it still returns the location of the whole series. I am wondering if there is a way to look at the specific occurrence.

For more context:

• The appointment takes place every two weeks on a Wednesday and is located in room 1. As such, it is set up as a recurring appointment a year at a time.
• On some weeks, room 1 is not available (even though it is booked, it becomes unavailable from time to time) and is changed to some other room (could be one of many, or even virtual. Basically it still needs to read the location line, not resources). As such, the specific occurrence of the recurrence's location changes.
• When the macro is run, room 1 is still returned even though that is not what the calendar says for that week.

Basically, I am hoping to make the macro read the location of the specific occurrence, not the whole series.

 

[shknbk2]

Had to look this one up because I was curious, too. It comes down to using the RecurrencePattern. Modify this to fit if it doesn't work as is. I added the RecurrencePattern stuff in the For loop, but the rest should be unchanged.

Function getLocation() As String
    Dim oApp As Outlook.Application, oCal As Outlook.Folder, appt As Outlook.AppointmentItem
    Dim explorerInstance As Outlook.Explorer, objNS As Outlook.NameSpace
    Dim ofldItems As Outlook.Items, sortItems As Outlook.Items
    Dim tdystart As Date, tdyend As Date
    Dim sRestrict As String
    Dim myRecipient As Outlook.Recipient
    
    tdystart = DateSerial(Year(Now), Month(Now), Day(Now))
    tdyend = DateSerial(Year(tdystart), Month(tdystart), Day(tdystart) + 2)
    Set oApp = CreateObject("Outlook.application")
    Set objNS = oApp.GetNamespace("MAPI")
    Set myRecipient = objNS.CreateRecipient("learning")
    myRecipient.Resolve
       
    If myRecipient.Resolved Then
        Set oCal = objNS.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
    End If
    
    If oCal Is Nothing Then
        For Each explorerInstance In oApp.Explorers
            If InStr(1, explorerInstance.Caption, "Calendar") > 0 Then
                Set oCal = explorerInstance.CurrentFolder
                Exit For
            End If
        Next
        If oCal Is Nothing Then
            Exit Function
        End If
    End If
    
    Set ofldItems = oCal.Items
    ofldItems.Sort ("[Start]")
    sRestrict = "[Start] >= '" & tdystart & "' and [End] <= '" & tdyend & "'"
    Set sortItems = ofldItems.Restrict(sRestrict)
    sortItems.Sort ("[Subject]")
    
    Dim myRecurrPatt As Outlook.RecurrencePattern
    For Each appt In sortItems
        If appt.Subject = "Hold For Onboarding - Matrix Welcome and Office Orientation" Then
            tdystart = tdystart + TimeSerial(Hour(appt.Start), Minute(appt.Start), Second(appt.Start))
            Set myRecurrPatt = appt.GetRecurrencePattern
            Set appt = myRecurrPatt.GetOccurrence(tdystart)
            getLocation = appt.Location
            Set appt = Nothing
            Set myRecurrPatt = Nothing
            Exit For
        End If
    Next appt
    
    MsgBox getLocation
 
    Set oApp = Nothing
    Set objNS = Nothing
    Set oCal = Nothing
    Set ofldItems = Nothing
    Set sortItems = Nothing
End Function

 

[Joshyd]

Hi Again,

Sorry for my lack of knowledge, but it is not working quite right and I cannot seem to get it functioning.

According to the Local window, everything goes great until:


"Set appt = myRecurrPatt.GetOccurrence(tdystart)"

at this point, it returns:

Run-time error '-2147467259 (8004005)':

You changed one of the recurrences of this item, and this instance no longer exists. Close any open items and try again.


I do not have any item open and am not sure what is going wrong. I did some searching online but cannot seem to resolve this and the fiddling I have done has been to no avail.

Thanks so much for all your help so far.

 

[Joshyd]

Perhaps I should not have sold myself short, figured out the problem. It was looking only at the day of tdystart even though the appointment could be on the next two days as well. I just added this modifier:

tdystart = DateSerial(Year(appt.Start), Month(appt.Start), Day(appt.Start))
tdystart = tdystart + TimeSerial(Hour(appt.Start), Minute(appt.Start), Second(appt.Start))

 

[shknbk2]

By chance, does the particular item have a different start time than the whole series? I can duplicate the error you got if I move an individual item to 11am when the series was originally set to 10am?

Trying to figure out how to step through the recurrences, but not having luck so far.

 

[shknbk2]

I just now saw your post #8 , but I'm not sure that solves your issue. When I add your fix, I just get the original appointment, not the one on today's calendar.

In case I'm wrong, though, I think I found something that will work. For the items that have been moved, they are Exceptions to the Recurrence. This code first tries to set the myRecurrAppt to the specific appt with today's date and the original time. If it succeeds (as it will likely do if the appt has not been moved), it proceeds. If it fails, it then goes through each exception and compares the dates. Since you mentioned that it could be up to 2 days later, I added the If statement to check for that (If D1 >= D2 And D1 <= D2 + 2 Then).

This new code works with my testing, but it might not be needed if I'm wrong as discussed above.

Function getLocation() As String
    Dim oApp As Outlook.Application, oCal As Outlook.Folder, appt As Outlook.AppointmentItem
    Dim explorerInstance As Outlook.Explorer, objNS As Outlook.NameSpace
    Dim ofldItems As Outlook.Items, sortItems As Outlook.Items
    Dim tdystart As Date, tdyend As Date
    Dim sRestrict As String
    Dim myRecipient As Outlook.Recipient
    
    tdystart = DateSerial(Year(Now), Month(Now), Day(Now))
    tdyend = DateSerial(Year(tdystart), Month(tdystart), Day(tdystart) + 2)
    Set oApp = CreateObject("Outlook.application")
    Set objNS = oApp.GetNamespace("MAPI")
    
    Set myRecipient = objNS.CreateRecipient("learning")
    myRecipient.Resolve

    If myRecipient.Resolved Then
        Set oCal = objNS.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
    End If

    If oCal Is Nothing Then
        For Each explorerInstance In oApp.Explorers
            If InStr(1, explorerInstance.Caption, "Calendar") > 0 Then
                Set oCal = explorerInstance.CurrentFolder
                Exit For
            End If

        Next
        If oCal Is Nothing Then
            Exit Function
        End If
    End If
    
    Set ofldItems = oCal.Items
    ofldItems.Sort ("[Start]")
    sRestrict = "[Start] >= '" & tdystart & "' and [End] <= '" & tdyend & "'"
    Set sortItems = ofldItems.Restrict(sRestrict)
    sortItems.Sort ("[Subject]")
    
    Dim myRecurrPatt As Outlook.RecurrencePattern, myException As Outlook.Exception
    Dim myExDate As Date, myRecurrAppt As AppointmentItem, D1 As Date, D2 As Date
    For Each appt In sortItems
        If appt.Subject = "Hold For Onboarding - Matrix Welcome and Office Orientation" Then
            tdystart = tdystart + TimeSerial(Hour(appt.Start), Minute(appt.Start), Second(appt.Start))
            Set myRecurrPatt = appt.GetRecurrencePattern
            On Error Resume Next
            Set myRecurrAppt = myRecurrPatt.GetOccurrence(tdystart)
            If Not myRecurrAppt Is Nothing Then
                getLocation = myRecurrAppt.Location
            Else
                For Each myException In myRecurrPatt.Exceptions
                    myExDate = 0
                    myExDate = myException.AppointmentItem.Start
                    D1 = DateSerial(Year(myExDate), Month(myExDate), Day(myExDate))
                    D2 = DateSerial(Year(tdystart), Month(tdystart), Day(tdystart))
                    If D1 >= D2 And D1 <= D2 + 2 Then
                        getLocation = myException.AppointmentItem.Location
                        Exit For
                    End If
                Next
            End If
            Exit For
        End If
    Next appt
    
    MsgBox getLocation
 
    Set oApp = Nothing
    Set objNS = Nothing
    Set oCal = Nothing
    Set ofldItems = Nothing
    Set sortItems = Nothing
    Set appt = Nothing
    Set myRecurrPatt = Nothing
End Function