This note is protected by password and is a Read Only.

Outlook Meeting Assassin

A Simple Outlook VBA scrip to limit the number of daily meetings. This script will automatically reject meeting requests for the following reasons: (all are configurable and can be turned off)
  • Exceeds the number of meetings you allow per day.
  • No location specified.
  • Conflicts with an existing meeting.
  • Start time is too close to the current time.
Exceptions can be easely set up via a normal outlook email rule (instructions below).

Instructions:

  1. Open Outlook and click ALT + F11, this will open the VBA editor.
  2. In the top-left object browser window, drill down to ThisOutlookSession and double click on it.
  3. Copy and paste to code below into the VBA editor window.
  4. Sub MeetingAssassin(oRequest As MeetingItem)

    Dim AllowedMeetingsPerDay As Integer
    Dim SoonestMeetingIn As Integer
    Dim oAppt As AppointmentItem
    Dim declinedReasons As String
    Dim oResponse As MeetingItem


    '**** Configuration ****
    AllowedMeetingsPerDay = 4 'How many meetings a day do you want to allow
    SoonestMeetingIn = 2 'How much notice do you need before a meeting can be scheduled (default is 2 hours from now). set to 0 to disable this rejection.
    NoLocationReject = 1 '1 = Reject meeting with no spesified, 0 = do not reject
    ConflictReject = 1 '1 = Reject conflicting schedule meetings, 0 = do not reject
    '**** Do not edit below this line ***'

    If oRequest.MessageClass <> "IPM.Schedule.Meeting.Request" Then
    Exit Sub
    End If

    Set oAppt = oRequest.GetAssociatedAppointment(True)

    declinedReasons = ""

    If (MeetingsCounter(oAppt) >= AllowedMeetingsPerDay) Then
    declinedReasons = declinedReasons & " * Too many meetings on this day (I only allow " & AllowedMeetingsPerDay & ")." & vbCrLf
    End If

    If (oAppt.Location = "") And (NoLocationReject = 1) Then
    declinedReasons = declinedReasons & " * No location specified." & vbCrLf
    End If

    If (HasConflicts(oAppt)) Then
    declinedReasons = declinedReasons & " * It conflicts with an existing appointment." & vbCrLf
    End If

    If (DateTime.DateDiff("h", DateTime.Now, oAppt.Start) < SoonestMeetingIn) Then
    declinedReasons = declinedReasons & " * The meeting's start time is too close to the current time. " & vbCrLf
    End If

    If (declinedReasons <> "") Then

    Set oResponse = oAppt.Respond(olMeetingDeclined, True)
    oResponse.Body = _
    "The number of meetings I have every day is out of control!!!" & vbCrLf & _
    "In an attempt to increase my productivity, an automated process rejected this meeting for the following reasons:" & vbCrLf & _
    declinedReasons & vbCrLf & vbCrLf & _
    MeetingsPerDay(AllowedMeetingsPerDay) & vbCrLf & vbCrLf & _
    "Simple implementation instructions for this feature can be found on my site at http://www.zakma.com/outlook-meeting-assassin"

    oResponse.Display
    oResponse.Send
    oRequest.Delete
    oAppt.Delete

    End If

    End Sub

    Function HasConflicts(oAppt As AppointmentItem) As Boolean
    Dim oCalendarFolder As Folder
    Set oCalendarFolder = ThisOutlookSession.Session.GetDefaultFolder(olFolderCalendar)

    Dim apptItem As AppointmentItem

    For Each apptItem In oCalendarFolder.Items
    If ((apptItem.BusyStatus <> olFree) And (oAppt <> apptItem)) Then
    If (apptItem.Start < oAppt.End) Then
    ' if this item starts before the given item ends, it must end before the given item starts
    If (apptItem.End > oAppt.Start) Then
    HasConflicts = True
    Exit Function
    End If
    End If
    End If
    Next

    HasConflicts = False
    End Function

    Function MeetingsCounter(oAppt As AppointmentItem) As Integer

    Dim oCalendarFolder As Folder
    Dim Counter As Integer

    Counter = 0

    Set oCalendarFolder = ThisOutlookSession.Session.GetDefaultFolder(olFolderCalendar)

    Dim apptItem As AppointmentItem

    For Each apptItem In oCalendarFolder.Items
    If (apptItem.BusyStatus <> olFree) And (Format(oAppt.Start, "yyyy-mm-dd") = Format(apptItem.Start, "yyyy-mm-dd")) Then
    Counter = Counter + 1
    End If
    Next

    Counter = Counter + DayOfWeekMeetings(Format(oAppt.Start, "w"))

    MeetingsCounter = Counter

    End Function

    Function MeetingsPerDay(AllowedMeetingsPerDay As Integer) As Variant

    Dim oCalendarFolder As Folder
    Dim apptItem As AppointmentItem
    Dim DateArr(10, 1) As Variant
    Dim MeetingList As Variant

    Set oCalendarFolder = ThisOutlookSession.Session.GetDefaultFolder(olFolderCalendar)


    For i = 0 To 9
    DateArr(i, 0) = Format(Date + i, "yyyy-mm-dd")
    DateArr(i, 1) = 0
    Next i

    For Each apptItem In oCalendarFolder.Items
    If (apptItem.BusyStatus <> olFree) And (Format(apptItem.Start, "yyyy-mm-dd")) >= Format(Date, "yyyy-mm-dd") Then
    For i = 0 To 9
    If DateArr(i, 0) = Format(apptItem.Start, "yyyy-mm-dd") Then
    DateArr(i, 1) = DateArr(i, 1) + 1
    End If
    Next i
    End If
    Next

    For i = 0 To 9
    MeetingList = MeetingList & Format(DateArr(i, 0), "dd-MMM-yyyy") & ": " & DateArr(i, 1) + DayOfWeekMeetings(Format(apptItem.Start, "w")) & IIf(DateArr(i, 1) <= AllowedMeetingsPerDay, " Meetings (Available for booking).", " (Fully booked).") & vbCrLf
    Next i

    MeetingsPerDay = MeetingList

    'Debug.Print MeetingList

    'Debug.Print Format(DateArr(0, 0), "dd-MMM-yyyy") & ": " & DateArr(0, 1) & " Meeting."
    'Debug.Print Format(DateArr(1, 0), "dd-MMM-yyyy") & ": " & DateArr(1, 1) & " Meeting."
    'Debug.Print Format(DateArr(2, 0), "dd-MMM-yyyy") & ": " & DateArr(2, 1) & " Meeting."


    End Function


    Function DayOfWeekMeetings(DayOfWeekNum As Integer) As Integer

    Dim ReOcccoringMeetings As Integer

    Select Case DayOfWeekNum
    Case 2
    ReOcccoringMeetings = 2
    Case 3
    ReOcccoringMeetings = 2
    Case 4
    ReOcccoringMeetings = 0
    Case 5
    ReOcccoringMeetings = 0
    Case 6
    ReOcccoringMeetings = 0
    End Select

    DayOfWeekMeetings = ReOcccoringMeetings

    End Function
  5. Edit any of the values under **** Configuration ****.
  6. Save your changes by clicking CTRL + S.
  7. Close the VBA window and in Outlook Email go to: Tools >> Rules and Alerts.
  8. Click on New Rule >> Next.
  9. Check "Where my name is in the To Box" and click Next.
  10. Check "Run a script" and click on "a script" in the bottom window.
  11. Select "Project1.ThisOutlookSession.MeetingAssassin" and click Ok.
  12. Click Finish
You may have a window asking you to approve the running of macros, accept/ok and you are all set.

If you'd like more/other functionality let me know, if you are nice enough I may implement and share it

None Private Note List:

URL Note Summary Days before delete
AllowedHtml <ul> <li><br> - Line break.</li> <li><o... 30137
BigDataFishig <b>#RealTimeData + #BigData + #Fishing</b>...teach... 30975
ChatSample Lee: Hello there, so can you explain how to chat u... 30137
Command-Line-Shortcuts <h3>Basic Keyboard Shortcuts</h3><b>Up/Down Arrows... 30223
dba <h2 style="display: inline;">Timeline:</h2> 21-Ja... 30166
dst_upgrade <h1>Oracle 11.2.0.2 DST Upgrade</h1><ol><li><b>che... 30201
Feedback ... 30081
hadoop_class_at_ebay eBay's North Campus, Parley room 2161 N. First ... 30260
mysql Get the size of a MYSQL Dababase: [code]SELECT ta... 30136
outlook-meeting-assassin <h1>Outlook Meeting Assassin</h1>A Simple Outlook ... 30695
Programming-Quotes <h3>Programming Quotes</h3> Java is to JavaScri... 30223
scrum <h2 style="margin: 0px 0px 0px 0px; padding: 0px 0... 867
vi <h2>vi cheat sheet</h2><b><u>Starting & ending com... 30142
websiteTricks-transperent [code]<!-- div.background { width:500px; h... 30081
xdb_installation <h1>Oracle XML DB (XDB) Installation</h1><ol> <li... 30201
zzzzzzzzzzz whycghkghfjjfhkctshsaqzmypqgrehghtmfggfhgoygvfjknm... 652

What else can I do with this?