#1
|
|||
|
|||
Automatically Creating an Appointment
I'm trying to find a way to automatically add a 30 minute appointment after every meeting I accept. I found the below code on the web, but it requires you to go into your calendar, select the meeting, then manually run the macro.
My thought was that I could add a custom button to the toolbar that acted as the "Accept" button and then schedule the 30 minute follow-up meeting. Any thoughts/assistance would be very much appreciated. Code:
Public Sub AddBreakTime() Dim coll As VBA.Collection Dim obj As Object Dim Appt As Outlook.AppointmentItem Dim FreeTime As Outlook.AppointmentItem Dim Items As Outlook.Items Dim Before&, After& Dim Category$, Subject$ '1. Block minutes before and after the appointment Before = 30 After = 30 If Before = 0 And After = 0 Then Exit Sub 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 If Before > 0 Then Set FreeTime = Items.Add FreeTime.Subject = "Free Time" FreeTime.Start = DateAdd("n", -Before, Appt.Start) FreeTime.Duration = Before FreeTime.Save End If If After > 0 Then Set FreeTime = Items.Add FreeTime.Subject = "Free Time" FreeTime.Start = Appt.End FreeTime.Duration = After FreeTime.Save 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 |
#2
|
|||
|
|||
Hi
you can try to use the event handler that fires when you send an item. Because when you accept a meeting you send an item. So you first check if it is a meeting request and if so you run your code. like this Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) If InStr(Item.MessageClass, "IPM.Schedule.Meeting.Request") > 0 Then 'do your thing here end if end sub |
Tags |
appointments, vba |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Creating a shopping list, where dublicates are automatically added | wasmabo | Excel | 7 | 01-10-2018 05:48 AM |
My text is wrapping automatically creating a new page | TheAnth | Word | 9 | 10-27-2017 05:53 PM |
Problem creating table of contents automatically | Badza.2020 | Word | 1 | 05-01-2015 04:58 PM |
Have Excel automatically send an appointment to Outlook | paulw793 | Excel | 1 | 09-12-2011 11:04 PM |
Creating an Appointment as an other User (Impersonating) | humpra | Outlook | 0 | 10-16-2009 03:36 AM |