VBA: Setting Optional Attendee Does Not Always Take

Question

I am trying to write VBA code to add attendees to a meeting.  It seems to work some of the time, but most of the time, the optional attendees get changed back to Regular Attendees.  Resource attendees always work (but I wonder if the recipient is flagged as a resource automatically).  I can see the attendees be set as optional (in both the OptionalAttendee property and the Recipient.Type =2 in the subroutine where it is set.  But when it goes back to the calling routine, often (I can't tell what the difference is when it works and not) it is reset, with the Type changing to 1, the OptionalAttendee list going to "", and the attendees that were supposed to be optional added to the RequiredAttendees list.

The calling routine contains code something like:

    Dim olApt As Object
    Dim olReqAttendee, olOptAttendee, olResAttendee As Outlook.Recipient
    Dim sReqAttendee, sOptAttendee, sResAttendee As String

    sReqAttendee = "John Smith; Jane Doe"
    sOptAttendee = "Tom Jones; Johnny Quest"

    Set olApt = olApp.CreateItem(olAppointmentItem)

                        

    OlApt.MeetingStatus = olMeeting              'identify as Meeting as opposed to Appointment

'   All the other meeting items are set here also, removed for brevity sake

    If Len(sReqAttendee) > 0 Then

        AddAttendees olApt, sReqAttendee, olReqAttendee, olRequired
    End If

    If Len(sOptAttendee) > 0 Then
        AddAttendees olApt, sOptAttendee, olOptAttendee, olCC  ' have also tried olOptional
    End If

    If Len(sResAttendee) > 0 Then
        AddAttendees olApt, sResAttendee, olResAttendee, olBCC  'have also used olResource
    End If

The function to Add Attendees is below:

 Sub AddAttendees(olObj As Object, sAttendee As String, thisAttendee As Variant, Optional olType As Variant)

    Dim arrRecipients As Variant
    Dim i As Integer
    Dim iLB, iUB As Integer
    
    arrRecipients = SplitRecipients(sAttendee)
    
    iLB = LBound(arrRecipients)
    iUB = UBound(arrRecipients)

    For i = iLB To iUB
        Set thisAttendee = olObj.recipients.Add(arrRecipients(i))
        If Not IsMissing(olType) Then thisAttendee.Type = olType
    Next i

  End Sub

Then the misc functions called are:

  Function SplitRecipients(strRecipients As Variant, Optional iLB As Integer = 0) As String()

  'Split string containing email addresses into array - break on either  ',' or ';' or vbLF

  Dim sTemp As String
  Dim sArr() As String
  Dim i, iUB As Integer

    sTemp = Replace(strRecipients, ",", ";")
    sTemp = Replace(sTemp, vbLf, ";")
    
   sArr = Split(sTemp, ";")
   
   iUB = UBound(sArr)
   i = LBound(sArr)
    
   While i <= iUB
        sArr(i) = Trim(sArr(i))
        If Len(sArr(i)) = 0 Then
            DeleteFromArray sArr, i
            iUB = iUB - 1
        Else
            i = i + 1
        End If
    Wend

  SplitRecipients = sArr

  End Function

  Sub DeleteFromArray(arr As Variant, ByVal element As Long)
    Dim li, newUB As Long
    
    newUB = UBound(arr) - 1
    For li = element To newUB
        arr(li) = arr(li + 1)
    Next li
    ReDim Preserve arr(LBound(arr) To newUB)
  End Sub

Any help would be greatly appreciated!

Answer 1

Hello Prostar,

Thank you for sharing the code. Note, you create an appointment object, not a meeting item.

To make a MeetingItem object available for the appointment object you need to set the MeetingStatus property, for example:

Sub CreateAppt()  
 Dim myItem As Object  
 Dim myRequiredAttendee, myOptionalAttendee, myResourceAttendee As Outlook.Recipient 
  
 Set myItem = Application.CreateItem(olAppointmentItem)  
 myItem.MeetingStatus = olMeeting  
 myItem.Subject = "Strategy Meeting"  
 myItem.Location = "Conference Room B"  
 myItem.Start = #9/24/1997 1:30:00 PM#  
 myItem.Duration = 90  
 Set myRequiredAttendee = myItem.Recipients.Add("Nate Sun")  
 myRequiredAttendee.Type = olRequired  
 Set myOptionalAttendee = myItem.Recipients.Add("Kevin Kennedy")  
 myOptionalAttendee.Type = olOptional  
 Set myResourceAttendee = myItem.Recipients.Add("Conference Room B")  
 myResourceAttendee.Type = olResource  
 myItem.Display  
End Sub

Answer 2

Eugene,

Thanks for the help.  I did have it set as a meeting, I just left that out of my sample of the calling routine.  I will see if I can update the original post to put that line in.

It does get created as a meeting.  The Optional Attendees work sometimes, using the EXACT same input.  The macro is called from an Excel spreadsheet that holds the meeting information.  I can run the macro repeatedly, without changing the data, and get different results with regards to the Optional Attendees.  Sometimes they hold as optional, but most of the time they revert back to required.  For example, I just ran the routine twice, using the same data in the spreadsheet each time.  There are 4 rows of data, each representing a meeting.  Each time, only 1 of the 4 meetings correctly held on to the Optional Attendees.  BUT, it was not the same meeting each time.  The first time the 4th meeting was correct, the second time the 2nd meeting was correct.  I am at a total loss.

Answer 3

Are you sure the code can run successfully?

I tried it but find it will not create a meeting item.

Answer 4

Yes, the code runs fine.  I did not post all of the original calling routine.  It always creates the meetings, and as I said, it assigns the optional attendees sometimes (well, it always assigns them in the subroutine, visible in both the myAttendee object and the olItem object), but it often loses the optional designation when it exits the subroutine.

The full calling routine is:

Function CreateAppointments(Optional ByVal autoSend As Boolean = False) As Long

    Dim olApp As Object
    Dim olApt As Object
    Dim rCount As Long
    Dim rNum As Long
    Dim lAdd As Long
    Dim wsCurrent As Worksheet
    
    Dim dStart As Date
    Dim dEnd As Date
    Dim sSubject As String
    Dim sLocation As String
    Dim sBody As String
    Dim eBusyStatus As Integer
    Dim iReminder As Integer
    Dim bReminder As Boolean
    Dim sCategories As String
    
    On Error GoTo SubError
    
'    Set olApp = New Outlook.Application
    Set olApp = CreateObject("Outlook.Application")
    
    Set wsCurrent = Sheets("Appointments")
    
    rCount = wsCurrent.Range("B1").Offset(wsCurrent.Rows.Count - 2, 0).End(xlUp).Row
    
    For rNum = 4 To rCount

'   Set Reminder
        
        If wsCurrent.Range("e" & rNum).Value > 0 Then
            bReminder = True
        Else
            bReminder = False
        End If

'   Set Busy flag

        If wsCurrent.Range("h" & rNum).Value = "Y" Then
            eBusyStatus = olBusy
        Else
            eBusyStatus = olFree
        End If
        
'   Add category Event Reminder to Appnt so we can identify which events were created by this macro
'   We will add to the other events entered in the spreadsheet.
'   There will most likely be categories to work with Outlook macro to automatically send emails as reminders

        sCategories = "Event Reminder"
        If Len(wsCurrent.Range("i" & rNum).Value) > 0 Then
            sCategories = sCategories & ", " & wsCurrent.Range("i" & rNum).Value
        End If
        
'   Create appointment

        bSuccess = SetApptMeeting(olApp, _
                   autoSend, _
                   wsCurrent.Range("b" & rNum).Value, _
                   wsCurrent.Range("c" & rNum).Value, _
                   wsCurrent.Range("d" & rNum).Value, _
                   wsCurrent.Range("e" & rNum).Value, _
                   IIf(wsCurrent.Range("e" & rNum).Value > 0, True, False), _
                   wsCurrent.Range("f" & rNum).Value, _
                   wsCurrent.Range("g" & rNum).Value, _
                   IIf(wsCurrent.Range("h" & rNum).Value = "Y", olBusy, olFree), _
                   sCategories, _
                   wsCurrent.Range("j" & rNum).Value)
                   

        If bSuccess Then lAdd = lAdd + 1
    
    Next rNum

SubError:
    CreateAppointments = lAdd
    Set olApp = Nothing

End Function

Answer 5

Try saving the item after adding the recipients, does it help?

---

Ken Slovak MVP - Outlook

Answer 6

I have noticed the following code above:

    For i = iLB To iUB
        Set thisAttendee = olObj.recipients.Add(arrRecipients(i))
        If Not IsMissing(olType) Then thisAttendee.Type = olType
    Next i

I'd recommend breaking the chain of code into separate lines of code, for example:

Dim myRecipient As Outlook.Recipient 
Dim myRecipients As Outlook.Recipients 
Set myRecipients = olObj.recipients
Set thisAttendee = myRecipients.Add(arrRecipients(i))
If Not IsMissing(olType) Then thisAttendee.Type = olType

If Not myRecipients.ResolveAll Then  
 For Each myRecipient In myRecipients  
   If Not myRecipient.Resolved Then  
     MsgBox myRecipient.Name  
   End If 
 Next  
End If 

Did you try to use the ResolveAll method of the Recipients class to resolve all the Recipient objects in the Recipients collection against the Address Book.

Also you can try to Save the Appointment item right after modifying the Recipients collection.

 

Answer 7

Eugene and Ken,

Thanks so much to both of you for your help.  As it turns out, saving the meeting did not seem to help on its own, but adding the .Resolveall did.  (I left in the save to be safe.)  My final sub looks like this:

Sub AddAttendees(olObj As Object, sAttendee As String, thisAttendee As Variant, Optional olType As Variant)
    Dim arrRecipients As Variant
    Dim i As Integer
    Dim iLB, iUB As Integer
    
On Error GoTo CleanUp:

    arrRecipients = SplitRecipients(sAttendee)
    
    iLB = LBound(arrRecipients)
    iUB = UBound(arrRecipients)

    For i = iLB To iUB
        Set thisAttendee = olObj.recipients.Add(arrRecipients(i))
        If Not IsMissing(olType) Then
            thisAttendee.Type = olType
        End If
    Next i
    
    olObj.recipients.ResolveAll
    If (Not IsMissing(olType) And olType = olOptional) Then
        olObj.Save  
    End If

CleanUp:

End Sub

I have run the routine multiple times  now and it always seems to work as designed.

Thanks again for your help!