Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Sanitized Outlook Event Forwarding Macro

Sanitized Outlook Event Forwarding

This is an example of what I use with my work calendar, when I need to forward something to my personal calendar.

This macro does not include any of the meeting content (who will be there, what the content is), but is just to block out the time to prevent your personal and professional lives from overlapping. This macro will create a new appointment for the time window, optionally including the subject (or replace it with [WORK]) and optionally including the location (or replace it with [WORK]).

After the invite has been sent, it deletes the invite, so it doesn't look like you've got two meetings at the same time.

It's also worth noting that you could potentially use the same code example to create a "travelling time" event before and after an appointment, if you're a person who travels to events (rather than telecommuting, you filthy animal ;) ) but I'll leave that as an exercise for the reader :)

Adding this in!

  1. Press Alt+F11 in MS Outlook to open the VBA Editor, and paste the content of the other file in. Replace "example@example.com" with your email address. Note: You are likely to get a notification that Macros are disabled. You will need to OK this each time it comes up (probably each time you trigger the macro for the first time).
  2. Open an outlook meeting or appointment. Right click on the ribbon, and select "Customize the ribbon...". Click on "Respond" on the "Main Tabs" block on the right, then click on "New group" and name it "Personal" (or choose your own ;) ). In the "Choose commands from" drop-down, select Macros, and then select the only macro in the box underneath. Click on the "Add >>" button in the middle. Click on "OK".
' Based on https://www.slipstick.com/developer/accept-or-decline-a-meeting-request-using-vba/
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
Set objApp = Nothing
End Function
Sub PersonalAcceptAndForward()
On Error GoTo ErrorExit
Dim oAppt As AppointmentItem
Dim cAppt As Object
Dim meAttendee As Outlook.Recipient
Dim oResponse
Dim rMsgBox
Dim bPreserveSubject As Boolean
Dim bPreserveLocation As Boolean
Dim sSubject As String
Dim sLocation As String
' This next line is adjusted from the above article - it used a function that is no longer available.
Set cAppt = GetCurrentItem()
Set oAppt = Application.CreateItem(olAppointmentItem)
sSubject = cAppt.Subject
sLocation = cAppt.Location
rMsgBox = MsgBox("Subject is: " & sSubject, vbYesNo, "Preserve Subject in Forward?")
If rMsgBox = vbNo Then
sSubject = "[Work]"
End If
rMsgBox = MsgBox("Location is: " & sLocation, vbYesNo, "Preserve Location in Forward?")
If rMsgBox = vbNo Then
sLocation = "[Work]"
End If
With oAppt
.MeetingStatus = olMeeting
.Subject = sSubject
.Start = cAppt.Start
.Duration = cAppt.Duration
.Location = sLocation
Set meAttendee = .Recipients.Add("example@example.com")
meAttendee.Type = olRequired
.Send
End With
oAppt.Delete
Set cAppt = Nothing
Set oAppt = Nothing
NormalExit:
On Error Resume Next
Set cAppt = Nothing
Set oAppt = Nothing
Exit Sub
ErrorExit:
MsgBox "Error (" & Err.Number & "): " & Err.Description
Resume NormalExit
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.