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

[murdoc34]

Hi Guys!

I had this article : social.technet.microsoft.com/Forums/ie/en-US/07b79803-e104-4244-bf8e-660d1b30e234/change-outlook-calendar-appoitments-default-time-to-25-mins-and-add-5-mins-break-recurring?forum=outlook

Basically, my desire is change the default appointments time from 30 mins to 25 mins and automatically add 5 mins break. Here is my prototype code , what I copied into the outlook vba part "ThisOutlookSession" under the Microsoft Outlook Objects.

In this moment with the below code, when I create an appointment it start default with 25 mins, after hit the save button, it will add 5 mins plus. e.g. Appointment start at 8:00 it will finish 8:25, and 5 mins add automatically, but you don't see the 5 mins. When you create another appointment it will start at 8:30 to 8:55 and add again 5 mins.

My problem with this code below, it is take like 10-14 seconds when I click in the calendar one session part to create an appointment. I don't know why, but maybe because of the code.
I would like to ask you guys , please help me to make it faster somehow, or just make it shorter.


Thank you in advance !

Laszlo




The CODE:

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
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
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

[skatonni]

This processes every item in the calendar.

A simple method would be to end processing once past the start date.

Private Sub objAppointment_OpenORIG2(Cancel As Boolean)

    'Set the default duration of new appointment
    If objAppointment.CreationTime = #1/1/4501# Then
        objAppointment.Duration = "25"
    End If
  
    Dim objAppoint As AppointmentItem
    Dim tmpAppoint As AppointmentItem
    Set tmpAppoint = objAppointment
    
    Dim itms As items
    Set itms = Application.Session.GetDefaultFolder(olFolderCalendar).items
    
    itms.Sort "[Start]", False
 
    For Each objAppoint In itms
 
        Debug.Print objAppoint.Start & " " & objAppoint.Subject
    
        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
        
        ' items are in order so exit after passing the start date
        If objAppoint.Start > objAppointment.Start Then Exit For
        
    Next objAppoint
    
End Sub

Delete all past appointments so they are removed from the processing.

If you do not want to delete old appointments use Restrict to limit items to the applicable date.