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
- 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
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:
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
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
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"