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 !:bow:: pray2:

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.