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 item and then try again. you can see the option.

if you have chosen option to do it on the fly, you will get the this screen

You can already have a look at the form and the associated code. Download it from here

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"

Ahh.. the article got stretched a bit because of the functionalities. Hope you enjoyed