Are you tired of manually finding free slots in your calendar to book appointments or schedule time for a specific task? With VBA, you can automate this process and increase your productivity by efficiently utilizing your available time. In this tutorial, we will show you how to write VBA code in Outlook to find a free slot in your calendar and book a specific time for a future task, all triggered by a specific action in an email. This tutorial will help you save time and streamline your workflow, allowing you to focus on more important tasks.
In this article, I will walk you through how this planned and achieved with VBA Macro. will also share a VBA userform. This can serve as learning for new comers in the area of Outlook VBA. For those who are only interested in getting the code and form and get it working, please scroll through to the bottom of the article. you will find a link to the downloadable
First, lets see what the target program would be capable of
Features:
- Select any outlook item like email or an appointment and block specified amount of time in the free slots my calendar
- If it is a appointment, after creating a new appointment, it should give me an option to delete the current appointment
- Subject of the meeting should be the same subject as selected item
- While creating an appointment, it should give me option to add few sentences as to what I want to do in the time slot
- It should add references to sender of email etc
- I should also be able to create an appointment on the fly from clipboard contents
- If if select some part of email while invoking the macro, it should put that part as reference in the appointment
If you select the checkbox "Create appointment with subject from from Clipboard", then meeting/appointment is not created from the email item. Rather it would be taken from clip board. This means, whatever you selected prior to running the macro would become subject line
If not mail or calendar item is selected but the macro is invoked, then it will give you options on whether you want to create an appointment on the fly or from clipboard or you want to choose an mail itema and then try again. you can see the option below
if you have chosen option to do it on the fly, you will get the following screen
You can already have a look at the form and the associated code
Now, lets shift our focus to the VBA macro code part. To ease the operation and navigation, the program is split in parts
Sub AutoAppoint() - the entry point to the program
This is a VBA macro for Microsoft Outlook that automates the process of creating an appointment from a selected email message or a user-typed text. The macro creates a new appointment item and sets its date and time based on the user's input. The macro also sets a reminder for the appointment and tags it with a category name.
Here is a brief description of the main parts of the macro:
- This module is responsible for bringing up GUI form to interact with users and receive the right inputs
- . The macro starts by defining some variables
- The macro then declares several object variables, such as objMsg to hold the currently selected mail item or appointment item, and wdDoc to hold the Word document object. The macro also defines some string variables to hold the appointment title and body.
- The macro then checks whether a mail item or appointment item is selected by the user. If no item is selected, the macro prompts the user to select a mail item or type in text. If a mail item is selected, the macro creates the appointment body using the selected text from the mail item. If an appointment item is selected, the macro sets the AppOnly flag to True and uses the appointment body and subject for creating a new appointment.
- The macro then displays a custom user form where the user can enter the date and time for the appointment, select a reminder time, and add any notes or comments. If the user selects the "Cancel" button, the macro exits. If the user selects the "OK" button, the macro retrieves the input data from the form and creates a new appointment item.
- The macro sets the appointment subject, location, start time, and end time based on the user's input. The macro also sets a reminder for the appointment and tags it with the category name. If the appointment is being created from a mail item, the macro sets the mail item's category name to the same as the appointment.
- Finally, the macro displays the newly created appointment and unloads the user form. The macro also clears the object variables to release memory resources.
Sub AutoAppoint()
'Option_Cat = ".My Action" ' Category name for tagging emails
GremindDays = "1"
myVersion = "1.8" ' Version number for this code
Dim objMsg As Object ' Object variable to hold the currently selected mail item or appointment item
Dim reminddays As Integer ' Number of days to set a reminder for
Dim countdays As Integer ' Not used in this code
Dim wdDoc As Object ' Word document object
Dim olInsp As Object ' Inspector object
Dim selection_text As String ' Text selected in the mail item body
Dim AppoTitle As String ' Title of the appointment
'Dim AppOnly As Boolean ' Flag to indicate if only an appointment is being created
Dim astr As String ' Temporary string variable
Dim prepend As String ' String to prepend to the appointment title
prepend = "Auto Booked:" ' This will be added to the appointment title later
Set objMsg = GetCurrentItem() ' Get the currently selected mail item or appointment item
On Error Resume Next
If objMsg Is Nothing Then ' No item is selected, prompt the user to select a mail item or type in text
Dim YesNocancel As Integer
YesNocancel = MsgBox("Please press Cancel to select a mail item and try again..." & vbCrLf & " OR" & vbCrLf & _
"Please press NO to type in Text" & vbCrLf & " OR" & vbCrLf & "Press Yes to use text below from clipboard :" & vbCrLf & _
"------------------------------" & vbCrLf & vbCrLf & PasteFromClipboard3 & vbCrLf & vbCrLf & "", vbYesNoCancel)
If YesNocancel = vbNo Then
astr = InputBox("Please type the subject of the topic", "Appointment Title")
App_body = astr & vbCrLf & "Action :" & vbCrLf & vbCrLf & vbCrLf & vbCrLf & _
"-------------------------" & vbCrLf & _
"Reference : Created from clipboard" & vbCrLf & _
vbCrLf
ElseIf YesNocancel = vbCancel Then
Exit Sub
Else
astr = PasteFromClipboard3()
If astr = "" Then astr = InputBox("Please type the subject of the topic", "Appointment Title")
App_body = astr & vbCrLf & "Action :" & vbCrLf & vbCrLf & vbCrLf & vbCrLf & _
"-------------------------" & vbCrLf & _
"Reference : Created from clipboard" & vbCrLf & _
vbCrLf
End If
ElseIf TypeOf objMsg Is MailItem Then ' A mail item is selected
'AppOnly = False
On Error GoTo 0
'flagname = objMsg.Categories
If TypeOf objMsg Is MailItem Then
Set olInsp = objMsg.GetInspector
Set wdDoc = olInsp.WordEditor
selection_text = wdDoc.Application.Selection.Range.Text
' Create the appointment body using the selected text from the mail item
App_body = "Action :" & vbCrLf & vbCrLf & selection_text & vbCrLf & vbCrLf & _
"-------------------------" & vbCrLf & _
"Reference :" & selection_text & vbCrLf & _
"Email From : " & objMsg.SenderName & vbCrLf & _
"With Subject : " & objMsg.Subject & vbCrLf & _
"Date : " & Format(objMsg.ReceivedTime, "dd-mm-yyyy hh:mm") & vbCrLf
Else
App_body = " "
End If
End If
If TypeOf objMsg Is AppointmentItem Then
AppOnly = True
App_body = objMsg.Body
App_sub = objMsg.Subject
App_reschedule = True
End If
MeetingForm.Meeting_Body.Value = App_body
MeetingForm.Caption = "Personal Assistant for Outlook " & myVersion
MeetingForm.Show
If MeetingForm.Check.Value = True Then
Unload MeetingForm
Exit Sub
End If
Dim appoday As Integer
Dim mSubject As String
Dim astring As String
astring = MeetingForm.Meeting_Body.Value
appoday = gimmeNumber(MeetingForm.Text_appo_date.Value)
If AppOnly = True Then
If App_reschedule = True Then
mSubject = App_sub
Call BlockNextFreeSlot(Date + appoday, mSubject)
Dim delYesNo As Integer
delYesNo = MsgBox("Do you want ot delete the currently selected item", vbYesNo)
If delYesNo = vbYes Then
objMsg.Delete
End If
AppOnly = False
App_reschedule = False
Else
mSubject = Split(astring, vbCrLf)(0) ' capturing the first part only
MsgBox (mSubject)
If mSubject = "" Then 'even if it does not have anything we take something from the body
If Len(astring) > 40 Then
mSubject = Left(astring, 40)
Else
mSubject = astring
End If
mSubject = Replace(mSubject, vbCrLf, " ")
End If
Call BlockNextFreeSlot(Date + appoday, mSubject)
End If
AppOnly = False
Else
Call BlockNextFreeSlot(Date + appoday, objMsg.ConversationTopic)
'If TimeBlocked = True And TypeOf objMsg Is MailItem Then objMsg.Categories = flagname
End If
TimeBlocked = False
MeetingForm.Show
Unload MeetingForm
Set objMsg = Nothing
Set wdDoc = Nothing
Set olInsp = Nothing
Exit Sub
End Sub
Function CheckAvailability()
This is a VBA function for Microsoft Outlook that checks if a given appointment can be scheduled without conflicts. The function takes three arguments: argChkDate, argChkTime, and duration. argChkDate and argChkTime together specify the start time of the appointment, and duration specifies the duration of the appointment.
The function first checks if the appointment start time is in the past. If it is, the function returns True to avoid booking an appointment in the past.
Then, the function uses the Microsoft Outlook object model to access the default calendar folder, and retrieves all items (appointments and meetings) in the specified time range. The time range is calculated based on the argChkDate and duration arguments. The function uses a filter to restrict the retrieved items to those that fall within the specified time range.
The function then loops through the filtered items to check for conflicts. If an item's start time or end time overlaps with the specified appointment, the function sets the return value to True and exits the loop. Otherwise, the function returns False.
The function uses several Microsoft Outlook objects, including Outlook.Application, Outlook.NameSpace, Outlook.MAPIFolder, Outlook.AppointmentItem, and Outlook.Items. It also uses the IncludeRecurrences property to include recurring appointments in the retrieved items, and the Restrict method to apply a filter to the retrieved items.
Lets see the code
Public Function CheckAvailability(ByVal argChkDate As Date, ByVal argChkTime As Date, ByVal duration As Date) As Boolean
Dim oApp As Object 'Outlook.Application
Dim oNameSpace As Object 'Outlook.NameSpace
Dim oApptItem As Object 'Outlook.AppointmentItem
Dim oFolder As Object 'Outlook.MAPIFolder
Dim oMeetingoApptItem As Object 'Outlook.meetingItem
Dim oObject As Object
Dim ItemstoCheck As Object 'Outlook.Items
Dim strRestriction As String
Dim FilteredItemstoCheck As Object 'Outlook.Items
Dim argCheckDate As Date
Dim daStart As String
Dim daEnd As Variant
'Combine the date and time arguments
argCheckDate = argChkDate + argChkTime
'Avoid past booking of calendar
If argCheckDate < Now Then
CheckAvailability = True
GoTo FUNCEXIT
End If
On Error Resume Next
'Check if Outlook is running
Set oApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
'If not running, start it
Set oApp = CreateObject("Outlook.Application")
End If
'Get the default calendar folder
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)
'Get all items in the calendar folder
Set ItemstoCheck = oFolder.Items
'Include recurring appointments
ItemstoCheck.IncludeRecurrences = True
'Sort the items by start date
ItemstoCheck.Sort "[Start]"
'Filter the items by the given date range
daStart = Format(argChkDate, "dd/mm/yyyy hh:mm AMPM")
daEnd = Format(argChkDate + 1, "dd/mm/yyyy hh:mm AMPM")
strRestriction = "[Start] >= '" & daStart & "' AND [End] <= '" & daEnd & "'"
Set FilteredItemstoCheck = ItemstoCheck.Restrict(strRestriction)
'Check if there is a conflicting appointment
CheckAvailability = False
For Each oObject In FilteredItemstoCheck
If oObject.Class = olAppointment Or oObject.Class = olMeetingRequest Then
Set oApptItem = oObject
If (oObject.Start = argCheckDate) _
Or oObject.End = (argCheckDate + duration) _
Or (argCheckDate > oObject.Start And argCheckDate < oObject.End) _
Or ((argCheckDate + duration) > oObject.Start And (argCheckDate + duration) < oObject.End) _
Or oObject.Start > argCheckDate And oObject.Start < (argCheckDate + duration) Then
CheckAvailability = True
Exit For
End If
End If
Next oObject
FUNCEXIT:
'Cleanup
Set oApp = Nothing
Set oNameSpace = Nothing
Set oApptItem = Nothing
Set oFolder = Nothing
Set oObject = Nothing
End Function
Private Function CreateAppointment()
The VBA subroutine creates a new appointment in Microsoft Outlook. It declares several variables including oApp (Outlook.Application), oNameSpace (NameSpace), oItem (AppointmentItem), iLastRow, prepend, and irow.
'It first sets a default subject for the appointment if none is provided, and then adds a prefix to the subject. It temporarily turns off error handling and attempts to get an existing instance of the Outlook application object or create a new one if none exists.
It then gets the MAPI namespace and creates a new AppointmentItem object. The appointment properties are then set including the subject, start time, duration, whether the appointment is an all-day event, importance, reminder time, categories, and body text.
If the "Busy" checkbox is unchecked, the busy status of the appointment is set to "tentative". The appointment is then saved, and a confirmation message is displayed.
'If the "Show Appointment" checkbox is checked, the appointment is displayed. Finally, the objects are cleaned up, and the subroutine returns a success status of "True".
Private Function CreateAppointment(ByVal argDate As Date, ByVal argTime As Date, Optional apposub As String) As Long
' Declare variables
Dim oApp As Object 'Outlook.Application
Dim oNameSpace As Object 'NameSpace
Dim oItem As Object 'AppointmentItem
Dim iLastRow As Long
Dim prepend As String
Dim irow As Long
' Set default subject if none is provided
If apposub = "" Then apposub = "Auto Booked"
' Add prefix to subject
prepend = "Auto Booked:"
' Turn off error handling temporarily
On Error Resume Next
' Get existing Outlook application object, or create a new one
Set oApp = GetObject(, "outlook.application")
If Err <> 0 Then
Set oApp = CreateObject("outlook.application")
End If
' Get the MAPI namespace
Set oNameSpace = oApp.GetNamespace("MAPI")
' Create a new AppointmentItem object
Set oItem = oApp.CreateItem(olAppointmentItem)
' Set appointment properties
With oItem
' Remove prefix from subject (if any) and add new prefix
apposub = Replace(apposub, "Auto Booked:", "")
.Subject = prepend + apposub
.Start = argDate + argTime
.duration = CInt(MeetingForm.TextBox3.Value)
.AllDayEvent = False
.Importance = olImportanceNormal
.ReminderMinutesBeforeStart = 15
.ReminderSet = True
'.Categories = flagname
' Set busy status to tentative if checkbox is unchecked
If MeetingForm.Busy.Value = False Then oItem.BusyStatus = olTentative
' Set body text if provided
If Not MeetingForm.Meeting_Body.Value = Empty Then .Body = MeetingForm.Meeting_Body.Value
' Save appointment
.Save
End With
' Display confirmation message
MsgBox "Appointment on " & Format(argDate + argTime, "d-mmm-yyyy hh:nn") & " for " & CInt(MeetingForm.TextBox3.Value) & " Min created", vbOKOnly
' Display appointment if checkbox is checked
If MeetingForm.CheckBox_Showappo.Value = True Then oItem.Display
' Clean up objects and return success status
Set oApp = Nothing
Set oNameSpace = Nothing
Set oItem = Nothing
CreateAppointment = True
End Function
Private Sub BlockNextFreeSlot()
This sub-routine blocks the next free time slot on a specified date for an appointment, if available. inputs:
dtDateToCheck - Date for which the time slot is to be checked.
apposubject - (optional) Appointment subject.
it loops between the stat and End work time to find any free slots using CheckAvailability() function and if free, block the calendar by using CreateAppointment() function
Code adapted from https://www.mrexcel.com/forum/excel-questions/531030-creating-calendar-entries-outlook-vb-userform-excel.html
Private Sub BlockNextFreeSlot(dtDateToCheck As Date, Optional apposubject As String)
' Set the minimum duration for a time slot to 30 minutes.
Dim min_Duration_for_slot As Date
min_Duration_for_slot = 30 / (24 * 60)
' Get the end time for the work day from the UserForm.
Dim WorkendTime As Date
WorkendTime = TimeValue(MeetingForm.TextBox2.Value)
' Get the duration of the appointment from the UserForm.
Dim TDuration As Date
If IsNumeric(MeetingForm.TextBox3.Value) Then
TDuration = CInt(MeetingForm.TextBox3.Value) / (24 * 60)
Else
TDuration = 10 / (24 * 60) ' Default duration is 10 minutes.
End If
' If the appointment duration is less than the minimum slot duration, set it as the new minimum.
If TDuration < min_Duration_for_slot Then min_Duration_for_slot = TDuration
' Get the start time of the appointment from the UserForm.
Dim dtTimeToCheck As Date
dtTimeToCheck = TimeValue(MeetingForm.TextBox1.Value)
' Check if the time slot is already taken, and if so, find the next available time slot.
Dim SlotIsTaken As Boolean
SlotIsTaken = True
Do Until Not SlotIsTaken Or dtTimeToCheck > WorkendTime
SlotIsTaken = CheckAvailability(dtDateToCheck, dtTimeToCheck, TDuration)
If SlotIsTaken Then dtTimeToCheck = dtTimeToCheck + min_Duration_for_slot ' Set the start time to the next available time slot.
Loop
' If there are no available time slots on the current day, prompt the user to try the next day.
If SlotIsTaken Then
Dim reruninput As VbMsgBoxResult
reruninput = MsgBox("No free slots on " & dtDateToCheck & " !!" & vbCrLf & vbCrLf & "Do you want me to try next day?", vbOKCancel)
If reruninput = vbOK Then Call BlockNextFreeSlot(dtDateToCheck + 1, apposubject)
Else
' If there is an available time slot, create the appointment.
If MeetingForm.ClipCheckBox.Value = True Then
apposubject = PasteFromClipboard3()
App_body = "Action :" & vbCrLf & vbCrLf & apposubject & vbCrLf & vbCrLf & _
"-------------------------" & vbCrLf & _
"Reference : Created from clipboard" & vbCrLf & _
apposubject & vbCrLf
End If
If CreateAppointment(dtDateToCheck, dtTimeToCheck, apposubject) Then
' If the appointment is successfully created, set TimeBlocked to True.
If MeetingForm.ClipCheckBox.Value = False Then
TimeBlocked = True
End If
Else
' If there is an error creating the appointment, display an error message.
MsgBox "Problem creating appointment for " & TDuration _
& " on " & Format(dtDateToCheck, "d-mmm-yyyy"), vbOKOnly + vbExclamation
End If
End If
End Sub
Other support functions:
Function GetCurrentItem()
The code block is a VBA function called GetCurrentItem, which retrieves the currently selected item in Microsoft Outlook. It starts by creating an instance of the Outlook application using the CreateObject method. Then, it checks the type of the active window to determine whether the user has selected an item in the Outlook explorer or is viewing an item in the inspector. If an item is selected in the explorer, the function retrieves the first selected item in the collection using the ActiveExplorer.Selection.Item(1) property. If the user is viewing an item in the inspector, the function retrieves the current item using the ActiveInspector.CurrentItem property. The function returns the selected or viewed item object to the calling procedure, or it returns nothing if an error occurs.
Function GetCurrentItem() As Object
On Error Resume Next
Dim App As Object
Set App = CreateObject("Outlook.Application")
Select Case TypeName(App.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = App.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = App.ActiveInspector.CurrentItem
Case Else
' anything else will result in an error, which is
' why we have the error handler above
End Select
Set App = Nothing
End Function
Function gimmeNumber()
This function can be used to calculate the number of days needed to complete a task while skipping weekends, based on the input parameters. The function takes a string input parameter called inpTextNum and an optional string parameter called extrainp. The function calculates the date that is a certain number of weekdays (excluding weekends) from the current date using the Weekday function and the vbMonday argument to specify Monday as the first day of the week. The function returns the integer value of the calculated number of weekdays as the result. If the inpTextNum parameter is not numeric, the function returns 0. This function can be used to calculate the number of days needed to complete a task while skipping weekends, based on the input parameters.
Function gimmeNumber(ByVal inpTextNum As String, Optional ByVal extrainp As String) As Integer
On Error Resume Next
If IsNumeric(inpTextNum) Then
gimmeNumber = CInt(inpTextNum)
If IsNumeric(extrainp) Then gimmeNumber = gimmeNumber + CInt(extrainp)
'MsgBox (Weekday(Date + countDays, vbMonday))
Select Case Weekday(Date + gimmeNumber, vbMonday) 'Skip weekends
'Case 1, 2, 3, 4, 5
'MsgBox ("l") 'DueDate = Date + countDays
Case 6
gimmeNumber = gimmeNumber + 2
Case 7
gimmeNumber = gimmeNumber + 1
End Select
Else
gimmeNumber = 0
End If
End Function
Sub validate_form()
Input validation and setting default, in case data is missing
Sub validate_form()
'No complaint but use my preference
If Not IsNumeric(MeetingForm.TextBox3.Value) Then MeetingForm.TextBox3.Value = 15
If Not IsNumeric(MeetingForm.Text_appo_date.Value) Then MeetingForm.Text_appo_date.Value = 3
If Not IsDate(MeetingForm.TextBox1.Value) Then MeetingForm.TextBox1.Value = "9:00"
If Not IsDate(MeetingForm.TextBox2.Value) Then MeetingForm.TextBox2.Value = "18:00"