Outlook macro function issue

Topic

New Reply

I needed a way to automatically block time after a meeting so I had a buffer (I get booked back to back with no breaks often). I found a VB macro online that adds a break both before and after a meeting, but I need to tweak it to only do the after meeting break and not do the before break.

It also shows up twice for each of the breaks and I only want one. I attempted some edits but either they didn’t work or more often, issued a runtime error.

The macro is this:

‘ Add to ThisOutlookSession
Option Explicit
Private WithEvents CalendarItems As Items
Dim myCalendar As Outlook.Folder

Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.Session

Set myCalendar = objNS.GetDefaultFolder(olFolderCalendar)
Set CalendarItems = myCalendar.Items

Set objNS = Nothing
End Sub

Private Sub CalendarItems_ItemAdd(ByVal Item As Object)
Dim TimeSpan As Long

‘how much time do you want to block (in minutes)
TimeSpan = 15

‘If Item.MeetingStatus = olMeeting Then
If Item.MeetingStatus = olMeeting Or Item.MeetingStatus = olMeetingReceived Then
On Error Resume Next

Dim oAppt As AppointmentItem
Set oAppt = Application.CreateItem(olAppointmentItem)

With oAppt
.Subject = “Meeting Prep Time ” & Item.Subject ’30 minutes before
.StartUTC = Item.StartUTC – TimeSpan / 1440
.Duration = TimeSpan
.BusyStatus = olBusy
.ReminderSet = False
.Save
End With

Set oAppt = Application.CreateItem(olAppointmentItem)
With oAppt
.Subject = “Meeting Review Time ” & Item.Subject
.Start = Item.End
‘ use number for duration if you are using a different length here
.Duration = TimeSpan
.BusyStatus = olBusy
.ReminderSet = False
.Save
End With
End If
End Sub

 

Last piece would be to have it self signed so I can keep my security level up.

Thanks

Reply | Quote

Replies

I think this will work – not tested.
I removed the first section that sets the start time.

cheers, Paul

' Add to ThisOutlookSession
Option Explicit
Private WithEvents CalendarItems As Items
Dim myCalendar As Outlook.Folder

Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.Session

Set myCalendar = objNS.GetDefaultFolder(olFolderCalendar)
Set CalendarItems = myCalendar.Items

Set objNS = Nothing
End Sub

Private Sub CalendarItems_ItemAdd(ByVal Item As Object)
Dim TimeSpan As Long

'how much time do you want to block (in minutes)
TimeSpan = 15

'If Item.MeetingStatus = olMeeting Then
If Item.MeetingStatus = olMeeting Or Item.MeetingStatus = olMeetingReceived Then
On Error Resume Next

Dim oAppt As AppointmentItem
Set oAppt = Application.CreateItem(olAppointmentItem)

With oAppt
.Subject = “Meeting Review Time ” & Item.Subject
.Start = Item.End
' use number for duration if you are using a different length here
.Duration = TimeSpan
.BusyStatus = olBusy
.ReminderSet = False
.Save
End With
End If
End Sub

Reply | Quote

Paul,

Thanks for this, I had it working and now I get an error for the last END IF- The error message says ” Compile error: End if without block if”. Not sure if I broke something or not. Here is what I have:

‘ Add to ThisOutlookSession
Option Explicit
Private WithEvents CalendarItems As Items
Dim myCalendar As Outlook.Folder

Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.Session

Set myCalendar = objNS.GetDefaultFolder(olFolderCalendar)
Set CalendarItems = myCalendar.Items

Set objNS = Nothing
End Sub

Private Sub CalendarItems_ItemAdd(ByVal Item As Object)
Dim TimeSpan As Long

‘how much time do you want to block (in minutes) TimeSpan = 15

‘If Item.MeetingStatus = olMeeting Then
If Item.MeetingStatus = olMeeting Or Item.MeetingStatus = olMeetingReceived Then On Error Resume Next

Dim oAppt As AppointmentItem
Set oAppt = Application.CreateItem(olAppointmentItem)

With oAppt
.Subject = “Meeting Review Time ” & Item.Subject
.Start = Item.End
‘ use number for duration if you are using a different length here
.Duration = TimeSpan
.BusyStatus = olBusy
.ReminderSet = False
.Save
End With
End If
End Sub

Reply | Quote

JTinLV wrote:

I broke something

A coders lament…

It might be a missing CR after the THEN in the meeting status test. Try the code below.

cheers, Paul

p.s. this site ruins code by changing quotes and apostrophes unless you do some trickery with your post

' Add to ThisOutlookSession
Option Explicit
Private WithEvents CalendarItems As Items
Dim myCalendar As Outlook.Folder

Private Sub Application_Startup()
	Dim objNS As NameSpace
	Set objNS = Application.Session

	Set myCalendar = objNS.GetDefaultFolder(olFolderCalendar)
	Set CalendarItems = myCalendar.Items

	Set objNS = Nothing
End Sub

Private Sub CalendarItems_ItemAdd(ByVal Item As Object)
	Dim TimeSpan As Long

	'how much time do you want to block (in minutes) TimeSpan = 15

	'If Item.MeetingStatus = olMeeting Then
	If Item.MeetingStatus = olMeeting Or Item.MeetingStatus = olMeetingReceived Then
		On Error Resume Next
		Dim oAppt As AppointmentItem
		Set oAppt = Application.CreateItem(olAppointmentItem)

		With oAppt
			.Subject = “Meeting Review Time ” & Item.Subject
			.Start = Item.End
			' use number for duration if you are using a different length here
			.Duration = TimeSpan
			.BusyStatus = olBusy
			.ReminderSet = False
			.Save
		End With
	End If
End Sub

Reply | Quote