I create a meeting in outlook, and add the room as a resource. Outlook then sends the room a meeting invite which it accepts, and that is how we book meeting rooms. I need to add a 15 minute meeting room booking for setups a lot of times. I'm trying to create a macro to do so, but am running into problems. I have it so it pulls everything now, but it will not send the invite. I don't know if its because the macro is for an appointment instead of a meeting, or if there is a way to adjust that etc.? Below is the code I have...
Code:
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
Else
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
Setup.Display
End If
End If
Next
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
Else
IsInspector = False
Set Sel = Win.Selection
If Not Sel Is Nothing Then
For i = 1 To Sel.Count
coll.add Sel(i)
Next
End If
End If
Set GetCurrentItems = coll
End Function