none
Change Outlook Calendar Appoitments Default Time to 25 mins and add 5 mins break recurring

    Question

  • Hi Everyone!

    I have an unusual request/ask/question.

    https://blogs.technet.microsoft.com/ewan/2013/11/08/tip-o-the-week-196-change-outlook-meeting-duration/<o:p></o:p>

    I found this very effective and useful article, where you can change the Outlook Calendar Default "30 mins" section to whatever you want to change, e.g. 25 mins. Everybody happy with this opportunity, because if you set up a meeting with 25 mins, you will save 5 mins for a break, or just go to one meeting to another with preparing, or just to use the bathroom, etc.....

    As you can see with this macro (below) , the default appointment section is 25 mins now. But when you highlight 2 sections in the calendar and hit the New Appointment it will set up again 25 mins instead of 50 mins. This is not a big problem, because the people can change it manually. On the other hand that can be a good change if there will be a 5 mins section after every single 25 mins section on default. I try to rewrite the macro code without success.... I attached a picture how I imagine this. If you start you day in a calendar and you click on one section it will looks like 8:00 am - 8:25 am. The next section automatically start from 8:30 am - 8:55 am and so on...

    Could you please help me to create this unique solution for everyone?

    Macro in the "ThisOutlookSession" :

    Private WithEvents objInspectors As Outlook.Inspectors
    Private WithEvents objAppointment As Outlook.AppointmentItem
     
    Private Sub Application_Startup()
        Set objInspectors = Outlook.Application.Inspectors
    End Sub

    Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
        If TypeOf Inspector.CurrentItem Is AppointmentItem Then
           Set objAppointment = Inspector.CurrentItem
        End If
    End Sub

    Private Sub objAppointment_Open(Cancel As Boolean)
        'Set the default duration of new appointment
        If objAppointment.CreationTime = #1/1/4501# Then
           objAppointment.Duration = "25"
        End If
    End Sub

    Private Sub objAppointment_PropertyChange(ByVal Name As String)
        'When you disable the "All Day Event"
        'Change the default duration of the current appointment
        If Name = "AllDayEvent" Then
           If objAppointment.AllDayEvent = False Then
              objAppointment.Duration = "25"
           End If
        End If
    End Sub

    In my dream basically the whole day has 5 mins break after 25 mins sections. And if you put there 2 sections, that can be 25+5+25=55 mins and you can change it manually to anything...

    I really hope I will get any advice, how can we create this in Outlook. Please help me guys !!!

    Thank you very much in advance every single advice or question or solutions.

    Friday, November 10, 2017 3:23 PM

Answers

  • Hi Laszlo,

    Sorry for my careless, I should share the whole code so it my be clearer to understand.

    In fact, I use the code after setting objAppointment.Duration in objAppointment_Open event.

    Its function is once you open an appointment, it will iterate through appointments and reset start time of appointments,which are in the same day and start after current appointment, 30 minutes later one by one. 

    Private Sub objAppointment_Open(Cancel As Boolean)
        If objAppointment.CreationTime = #1/1/4501# Then
           objAppointment.Duration = "25"
        End If
        Dim objAppoint As AppointmentItem
        Dim tmpAppoint As AppointmentItem
        Set tmpAppoint = objAppointment
        Dim items As items
        Set itms = Application.Session.GetDefaultFolder(olFolderCalendar).items
        itms.Sort "[Start]", False
        For Each objAppoint In itms
        If Format(objAppoint.Start, "yyyy/mm/dd") = Format(objAppointment.Start, "yyyy/mm/dd") _
                And Not objAppoint.EntryID = objAppointment.EntryID _
                And objAppoint.Start > objAppointment.Start Then
        objAppoint.Start = DateAdd("n", 25 + 5, tmpAppoint.Start)
        objAppoint.Save
        Set tmpAppoint = objAppoint
        End If
        Next objAppoint
    End Sub

    Here is the whole code(with little update) and the gif for demonstrating. Is it what you want?


    Best Regards,

    Terry


    MSDN Community Support Please remember to click &amp;quot;Mark as Answer&amp;quot; the responses that resolved your issue, and to click &amp;quot;Unmark as Answer&amp;quot; if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.


    Friday, November 17, 2017 9:06 AM

All replies

  • Hi,

    Since your query is macro related, I'm moving it to the following dedicated Outlook for developer forum. There you should get more professional responses:

    https://social.msdn.microsoft.com/Forums/office/en-US/home?forum=outlookdev

    The reason why we recommend posting appropriately is you will get the most qualified pool of respondents, and other partners who read the forums regularly can either share their knowledge or learn from your interaction with us. Thank you for your understanding.

    Regards,

    Ethan Hua


    Please remember to mark the replies as answers if they helped.
    If you have feedback for TechNet Subscriber Support, contact tnsf@microsoft.com.

    Monday, November 13, 2017 7:48 AM
  • Thank you Ethan !
    Tuesday, November 14, 2017 9:57 AM
  • Hello,

    You could try to refer to below code .

      Dim objAppoint As AppointmentItem
        Dim tmpAppoint As AppointmentItem
        Set tmpAppoint = objAppointment
        Dim items As items
        Set itms = Application.Session.GetDefaultFolder(olFolderCalendar).items
        itms.Sort "[Start]", False
        For Each objAppoint In itms
        If Format(objAppoint.Start, "yyyy/mm/dd") = Format(objAppointment.Start, "yyyy/mm/dd") And Not objAppoint.EntryID = objAppointment.EntryID Then
        objAppoint.Start = DateAdd("n", 25 + 5, tmpAppoint.Start)
        objAppoint.Save
        Set tmpAppoint = objAppoint
        End If
        Next objAppoint

    Best Regards,

    Terry


    MSDN Community Support Please remember to click &amp;quot;Mark as Answer&amp;quot; the responses that resolved your issue, and to click &amp;quot;Unmark as Answer&amp;quot; if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Thursday, November 16, 2017 7:23 AM
  • Hi Terry,

    I tried your code and it is not working. But I'm not sure I did on the right way. Do you want me to replace the original code with yours, or just expand it!

    Please forgive me , I'm on a very beginner level with coding in the outlook :)

    Thank you

    Laszlo

    Thursday, November 16, 2017 2:24 PM
  • Hi Laszlo,

    Sorry for my careless, I should share the whole code so it my be clearer to understand.

    In fact, I use the code after setting objAppointment.Duration in objAppointment_Open event.

    Its function is once you open an appointment, it will iterate through appointments and reset start time of appointments,which are in the same day and start after current appointment, 30 minutes later one by one. 

    Private Sub objAppointment_Open(Cancel As Boolean)
        If objAppointment.CreationTime = #1/1/4501# Then
           objAppointment.Duration = "25"
        End If
        Dim objAppoint As AppointmentItem
        Dim tmpAppoint As AppointmentItem
        Set tmpAppoint = objAppointment
        Dim items As items
        Set itms = Application.Session.GetDefaultFolder(olFolderCalendar).items
        itms.Sort "[Start]", False
        For Each objAppoint In itms
        If Format(objAppoint.Start, "yyyy/mm/dd") = Format(objAppointment.Start, "yyyy/mm/dd") _
                And Not objAppoint.EntryID = objAppointment.EntryID _
                And objAppoint.Start > objAppointment.Start Then
        objAppoint.Start = DateAdd("n", 25 + 5, tmpAppoint.Start)
        objAppoint.Save
        Set tmpAppoint = objAppoint
        End If
        Next objAppoint
    End Sub

    Here is the whole code(with little update) and the gif for demonstrating. Is it what you want?


    Best Regards,

    Terry


    MSDN Community Support Please remember to click &amp;quot;Mark as Answer&amp;quot; the responses that resolved your issue, and to click &amp;quot;Unmark as Answer&amp;quot; if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.


    Friday, November 17, 2017 9:06 AM
  • Hi Terry,

    It is working very nicely :)

    Only one thing, when I create an appointment or anything else, it is happening very slowly, I understand the macro is working in the back, but why is it so slow? Do you have any idea to check something or optimize something somehow? Anyway I mark it for answer! Great Job!

    Thank you!

    Laszlo

    22 hours 30 minutes ago