Macro for adding a 15 minute setup meeting before primary meeting with room invite? RRS feed

  • Question

  • I'm trying to build a macro that will take my meeting info, and create a 15 minute setup meeting before it, and invite the room resource too.  Below is what I have so far.  BUT its not 100% complete.  It will pull the room resource, subject, location, etc.  But it doesn't send the room invite.  When the setup meeting window opens so I can view it, If I check "scheduling assistant" the room is listed under the resource attendee, but in the main window there is no "To" line, so it never sends the invite to the room.  is there a way I can resolve this?  Below is my code, I' know I'm missing something.  Help is GREATLY appreciated!

    Public Sub Setup()
      Dim coll As VBA.Collection
      Dim obj As Object
      Dim Appt As Outlook.AppointmentItem
      Dim Setup As Outlook.AppointmentItem
      Dim Items As Outlook.Items
      Dim Before&, After&
      Dim Category$, Subject$
      '1. Block minutes before and after the appointment
      Before = 15
      '2. Skip this if the default values never change
      Before = InputBox("Minutes before:", , Before)
      If Before = 0 Then Exit Sub
      '3. Assign this category
      Category = "Setup"
      Set coll = GetCurrentItems
      If coll.Count = 0 Then Exit Sub
      For Each obj In coll
        If TypeOf obj Is Outlook.AppointmentItem Then
          Set Appt = obj
          If TypeOf Appt.Parent Is Outlook.AppointmentItem Then
            Set Items = Appt.Parent.Parent.Items
            Set Items = Appt.Parent.Items
          End If
          '4. Use the main appointment's attribute
          Subject = Appt.Subject
          Location = Appt.Location
          Resources = Appt.Resources
          If Before > 0 Then
            Set Setup = Items.add
            Setup.Subject = Subject + " setup"
            Setup.Location = Location
            Setup.Resources = Resources
            Setup.Start = DateAdd("n", -Before, Appt.Start)
            Setup.Duration = Before
            Setup.Categories = Category
          End If
        End If
    End Sub
    Private Function GetCurrentItems(Optional IsInspector As Boolean) As VBA.Collection
      Dim coll As VBA.Collection
      Dim Win As Object
      Dim Sel As Outlook.Selection
      Dim obj As Object
      Dim i&
      Set coll = New VBA.Collection
      Set Win = Application.ActiveWindow
      If TypeOf Win Is Outlook.Inspector Then
        IsInspector = True
        coll.add Win.CurrentItem
        IsInspector = False
        Set Sel = Win.Selection
        If Not Sel Is Nothing Then
          For i = 1 To Sel.Count
            coll.add Sel(i)
        End If
      End If
      Set GetCurrentItems = coll
    End Function

    Friday, May 3, 2019 7:01 PM

All replies