Creating calendar entries in outlook from VB userform/excel

P

philfloyduk

Board Regular
Joined
Jan 6, 2011
Messages
82
I have a repair booking form in visual basic that feeds in to an excel sheet that I would like to automatically create calendar entries in outlook. Ideally, the next free hourly slot would be taken (our repairs are put on to the day then organised in the morning). The form has a textbox that the user enters the appointment date in via calendar control 12.0. The form currently populates all the information needed from the text boxes in to a cell, copies the information then prompts the user to paste it to the Calendar.

Many thanks in advance for any help


Phil.
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
Sort by date Sort by votes
This code will create a calendar entry:-
Code: 
Option Explicit
 
Public Sub CreateAppointment()
 
  Dim oApp As Outlook.Application
  Dim oNameSpace As Namespace
  Dim oItem As AppointmentItem
  Dim iLastRow As Long
  Dim irow As Long
     
  On Error Resume Next
[COLOR=green]  ' check if Outlook is running
[/COLOR]  Set oApp = GetObject("outlook.application")
  If Err <> 0 Then
    'if not running, start it
    Set oApp = CreateObject("Outlook.Application")
  End If
  
[COLOR=green]' On Error GoTo Err_Handler
[/COLOR]  
  Set oNameSpace = oApp.GetNamespace("MAPI")
  
  Set oItem = oApp.CreateItem(olAppointmentItem)
  With oItem
    .Subject = "This is the subject"
    .Start = "22/02/2011 20:00"
    .Duration = "01:00"
    
    .AllDayEvent = False
    .Importance = olImportanceNormal
    .Location = "Room 101"    
    .ReminderSet = True
    .ReminderMinutesBeforeStart = "10"
    .ReminderPlaySound = True
    .ReminderSoundFile = "C:\Windows\Media\Ding.wav"
    
    Select Case 1[COLOR=green] ' do you want to display the entry first or save it immediately?
[/COLOR]      Case 1
        .Display
      Case 2
        .Save
    End Select
  
  End With
    
  Set oApp = Nothing
  Set oNameSpace = Nothing
  Set oItem = Nothing
  Exit Sub
You need to add a reference to the Microsoft Outlook Object Library in VBA.
 
Upvote 0
Thank you for that.

Sorry if this is obvious but how would I create the reference to the Microsoft Outlook Object Library in VBA? Is it straight forward?

I assume it's not possible to go for the next available appointment? Ideally it'd put the first of the day at 9:00 then take the next hour slot from there on.

Regards,

Phil
 
Upvote 0
Sorry, yes, it's under Tools > References: scroll down to find it, tick the box and click OK.

The full list of properties for the Appoimntment item can be found here: http://msdn.microsoft.com/en-us/library/aa210899(v=office.11).aspx.

As for reading the calendar, I've never done that. You'd need to read the existing appointments and work out where the free slots were.

If I get a chance tomorrow I'll take a look at it but if anyone else is reading this who knows how, please feel free to chip in!
 
Upvote 0
Here's something: paste this lot into a new module, change the date/times in the Driver routine and run it. It calls GetAppointments and any appointments within those date/times are copied to the worksheet. (Obviously when you're running your system you won't actually put stuff on the worksheet.

If you put the same date/time as both parameters, GetAppointments will fetch any appointments which start at exactly that date/time. It could quite easily be turned into a function which you pass a single date/time to and it returns a True/False depending on whether the slot has an appointment in it or not.

Code: 
[FONT=Courier New][SIZE=1]Option Explicit[/SIZE][/FONT]
[FONT=Courier New][SIZE=1] [/SIZE][/FONT]
[FONT=Courier New][SIZE=1]Public Sub Driver()[/SIZE][/FONT]
[FONT=Courier New][SIZE=1] [/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  Call GetAppointments( _[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]       DateValue("01/02/2011") + TimeValue("08:00:00"), _[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]       DateValue("28/02/2011") + TimeValue("18:00:00"))[/SIZE][/FONT]
[FONT=Courier New][SIZE=1] [/SIZE][/FONT]
[FONT=Courier New][SIZE=1]End Sub[/SIZE][/FONT]
[FONT=Courier New][SIZE=1] [/SIZE][/FONT]
[FONT=Courier New][SIZE=1]Public Sub GetAppointments(ByVal argStartDate As Date, ByVal argEndDate As Date)[/SIZE][/FONT]
[FONT=Courier New][SIZE=1] [/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  Dim oApp As Outlook.Application[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  Dim oNameSpace As Outlook.Namespace[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  Dim oApptItem As Outlook.AppointmentItem[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  Dim oFolder As Outlook.MAPIFolder[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  Dim oMeetingoApptItem As Outlook.MeetingItem[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  Dim oObject As Object[/SIZE][/FONT]
[FONT=Courier New][SIZE=1] [/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  Dim sErrorMessage As String[/SIZE][/FONT]
[FONT=Courier New][SIZE=1] [/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  Dim irow As Long[/SIZE][/FONT]
[FONT=Courier New][SIZE=1] [/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  On Error Resume Next[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  ' check if Outlook is running[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  Set oApp = GetObject("Outlook.Application")[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  If Err <> 0 Then[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]    'if not running, start it[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]    Set oApp = CreateObject("Outlook.Application")[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  End If[/SIZE][/FONT]
[FONT=Courier New][SIZE=1] [/SIZE][/FONT]
[FONT=Courier New][SIZE=1]' On Error GoTo Err_Handler[/SIZE][/FONT]
[FONT=Courier New][SIZE=1] [/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  Set oNameSpace = oApp.GetNamespace("MAPI")[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)[/SIZE][/FONT]
[FONT=Courier New][SIZE=1] [/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  Rows("2:" & CStr(Rows.Count)).ClearContents[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  irow = 1[/SIZE][/FONT]
[FONT=Courier New][SIZE=1] [/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  For Each oObject In oFolder.Items[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]    If oObject.Class = olAppointment Then[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]      Set oApptItem = oObject[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]      If oApptItem.Start >= argStartDate And oApptItem.Start <= argEndDate Then[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]        irow = irow + 1[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]        Cells(irow, 1) = Format(oApptItem.Start, "dd/mm/yyyy")[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]        Cells(irow, 2) = Format(oApptItem.Start, "hh:nn")[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]        Cells(irow, 3) = oApptItem.Duration[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]        Cells(irow, 4) = oApptItem.Subject[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]        Cells(irow, 5) = oApptItem.Location[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]      End If[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]    End If[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  Next oObject[/SIZE][/FONT]
[FONT=Courier New][SIZE=1] [/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  Set oApp = Nothing[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  Set oNameSpace = Nothing[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  Set oApptItem = Nothing[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  Set oFolder = Nothing[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  Set oObject = Nothing[/SIZE][/FONT]
[FONT=Courier New][SIZE=1] [/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  Exit Sub[/SIZE][/FONT]
[FONT=Courier New][SIZE=1] [/SIZE][/FONT]
[FONT=Courier New][SIZE=1]Err_Handler:[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  sErrorMessage = Err.Number & " " & Err.Description[/SIZE][/FONT]
[FONT=Courier New][SIZE=1] [/SIZE][/FONT]
[FONT=Courier New][SIZE=1]End Sub[/SIZE][/FONT]

Play with this and see if it (a) runs at all and/or (b) is any use.
 
Last edited:
Upvote 0
This is the same code as a function: change the date/times in the Driver routine - one for an appointment which does exist, one for an appointment which doesn't exist - and run it. CheckAppointment checks whether each one exists and returns True or False.

Code: 
[FONT=Courier New][SIZE=1]Option Explicit[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]Public Sub Driver()[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]  Dim dtCheck As Date[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]  dtCheck = DateValue("[COLOR=red][B]22/02/2011[/B][/COLOR]") + TimeValue("[COLOR=red][B]16:00:00[/B][/COLOR]")
  If CheckAppointment(dtCheck) Then
    MsgBox "Appointment found at " & Format(dtCheck, "dd/mm/yyyy hh:nn:ss"), vbOKOnly + vbInformation
  Else
    MsgBox "Appointment not found at " & Format(dtCheck, "dd/mm/yyyy hh:nn:ss"), vbOKOnly + vbExclamation
  End If
  
  dtCheck = DateValue("[COLOR=red][B]23/02/2011[/B][/COLOR]") + TimeValue("[COLOR=red][B]09:00:00[/B][/COLOR]")
  If CheckAppointment(dtCheck) Then
    MsgBox "Appointment found at " & Format(dtCheck, "dd/mm/yyyy hh:nn:ss"), vbOKOnly + vbInformation
  Else
    MsgBox "Appointment not found at " & Format(dtCheck, "dd/mm/yyyy hh:nn:ss"), vbOKOnly + vbExclamation
  End If
  
End Sub[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]Public Function CheckAppointment(ByVal argCheckDate As Date) As Boolean[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]  Dim oApp As Outlook.Application
  Dim oNameSpace As Outlook.Namespace
  Dim oApptItem As Outlook.AppointmentItem
  Dim oFolder As Outlook.MAPIFolder
  Dim oMeetingoApptItem As Outlook.MeetingItem
  Dim oObject As Object
  
  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
  
[/SIZE][/FONT][FONT=Courier New][SIZE=1]  Set oNameSpace = oApp.GetNamespace("MAPI")
  Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)
  
  CheckAppointment = False
  For Each oObject In oFolder.Items
    If oObject.Class = olAppointment Then
      Set oApptItem = oObject
      If oApptItem.Start = argCheckDate Then
        CheckAppointment = True
      End If
    End If
  Next oObject
    
  Set oApp = Nothing
  Set oNameSpace = Nothing
  Set oApptItem = Nothing
  Set oFolder = Nothing
  Set oObject = Nothing
   
End Function[/SIZE][/FONT]

This might be more useful to you: you'd start at 9am on the day, check whether the slot is free, add half an hour, check the next slot, etc, until you find a free slot. You could skip the lunch hour if required. If you get to 6pm I suppose you could flip over to 9am the following day if necessary.
 
Upvote 0
Fantastic!

I've got the calendar popping up when I run the code so will play with that and decide whether the user should confirm or if it autosaves. I had to remove the 'Option Explicit' line because with it it was effecting some of the other code on the form, is this a problem?

I'll have a look at the other code you've given me and see if I can manipulate it to put appointments in the next available slot. I suspect this may be beyond my capabilities though so like you say, if anyone else is reading this and knows how to do it your input will be welcomed.

Thanks very much for the time you've spent helping me, it's really appreciated.

Phil
 
Upvote 0
Option Explicit forces you to think carefully about your data types: this is A Good Thing.

It also allows the compiler to warn you when you misspell a variable name: this is also A Good Thing.

Paste this code into a new module in the same workbook as CheckAppointment. It sets up a date (which your user would pick from a calendar control), then starting from 8.30am it looks for a free half-hour slot, ending at 5.30pm. If it finds a free slot, it tells you via a MsgBox - you'd insert your own code for creating an appointment at this point.

If it doesn't find one, it also tells you and you'd have to decide what to do with that - warn the user and ask him to pick a new date, for example.
Code: 
Option Explicit
 
Sub FindNextFreeSlot()
 
  Dim dtDateToCheck As Date
  Dim dtTimeToCheck As Date
  Dim SlotIsTaken As Boolean
  
  dtDateToCheck = DateValue("[COLOR=blue][B]23-Feb-2011[/B][/COLOR]") [COLOR=green]' you'd pick this from the calendar control[/COLOR]
  dtTimeToCheck = TimeValue("[COLOR=red][B]08:30:00[/B][/COLOR]")[COLOR=green] ' first slot of the day
[/COLOR]  
  SlotIsTaken = CheckAppointment(dtDateToCheck + dtTimeToCheck)
  Do Until Not SlotIsTaken Or dtTimeToCheck = TimeValue("[B][COLOR=magenta]17:30:00[/COLOR][/B]")[COLOR=green] ' last slot of the day[/COLOR]
    dtTimeToCheck = dtTimeToCheck + TimeValue("[COLOR=red][B]00:30:00[/B][/COLOR]") [COLOR=green]' duration of each slot[/COLOR]
    SlotIsTaken = CheckAppointment(dtDateToCheck + dtTimeToCheck)
  Loop
  
  If SlotIsTaken Then
    MsgBox "No free slots today!", vbOKOnly + vbExclamation  [COLOR=green]' you have to decide what to do in this event[/COLOR]
  Else
    MsgBox "Next free slot is " & Format(dtTimeToCheck, "hh:nn"), vbOKOnly + vbInformation [COLOR=green]' your code for creating a new appointment goes here[/COLOR]
  End If
 
End Sub
To test, set the date (the code in blue) to a day when your calendar is empty and run FindNextFreeSlot: it should return 08:30. Now create an appointment for 08:30 (manually) and run FindNextFreeSlot again: it should return 09:00.

Finally create an appointment for 09:00 (manually) and change the 'last slot of the day' variable (in pink) to "09:00:00" and run FindNextFreeSlot again: it should warn "No free slots today!".

Shout if any problems!
 
Upvote 0
When you've got your head round that lot, here's the next step. Start with a blank workbook and paste these procedures into three separate standard code modules. Add a reference to the Microsoft Outlook Objects Library.
Code: 
[FONT=Courier New][SIZE=1]Option Explicit[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]Sub FindNextFreeSlot()[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]  Dim dtDateToCheck As Date
  Dim dtTimeToCheck As Date
  Dim SlotIsTaken As Boolean
  
  dtDateToCheck = DateValue("[COLOR=red][B]21-Feb-2011[/B][/COLOR]")
  dtTimeToCheck = TimeValue("[COLOR=red][B]08:30:00[/B][/COLOR]")
  
  SlotIsTaken = CheckAppointment(dtDateToCheck + dtTimeToCheck)
  Do Until Not SlotIsTaken Or dtTimeToCheck = TimeValue("16:30:00")
    dtTimeToCheck = dtTimeToCheck + TimeValue("00:30:00")
    SlotIsTaken = CheckAppointment(dtDateToCheck + dtTimeToCheck)
  Loop
  
  If SlotIsTaken Then
    MsgBox "No free slots today!", vbOKOnly + vbExclamation
  Else
    If CreateAppointment(dtDateToCheck, dtTimeToCheck) Then
      MsgBox "Appointment for " & Format(dtTimeToCheck, "hh:nn") _
           & " on " & Format(dtDateToCheck, "d-mmm-yyyy") & " created", _
           vbOKOnly + vbInformation
    Else
      MsgBox "Problem creating appointment for " & Format(dtTimeToCheck, "hh:nn") _
           & " on " & Format(dtDateToCheck, "d-mmm-yyyy"), vbOKOnly + vbExclamation
    End If
  End If[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]End Sub[/SIZE][/FONT]
Code: 
[FONT=Courier New][SIZE=1]Option Explicit[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]Public Function CheckAppointment(ByVal argCheckDate As Date) As Boolean[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]  Dim oApp As Outlook.Application
  Dim oNameSpace As Outlook.Namespace
  Dim oApptItem As Outlook.AppointmentItem
  Dim oFolder As Outlook.MAPIFolder
  Dim oMeetingoApptItem As Outlook.MeetingItem
  Dim oObject As Object
  
  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
  
[/SIZE][/FONT][FONT=Courier New][SIZE=1]  Set oNameSpace = oApp.GetNamespace("MAPI")
  Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)
  
  CheckAppointment = False
  For Each oObject In oFolder.Items
    If oObject.Class = olAppointment Then
      Set oApptItem = oObject
      If oApptItem.Start = argCheckDate Then
        CheckAppointment = True
      End If
    End If
  Next oObject
    
  Set oApp = Nothing
  Set oNameSpace = Nothing
  Set oApptItem = Nothing
  Set oFolder = Nothing
  Set oObject = Nothing
   
End Function[/SIZE][/FONT]
Code: 
[FONT=Courier New][SIZE=1]Option Explicit[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]Public Function CreateAppointment(ByVal argDate As Date, ByVal argTime As Date) As Long[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]  Dim oApp As Outlook.Application
  Dim oNameSpace As Namespace
  Dim oItem As AppointmentItem
  Dim iLastRow As Long
  Dim irow As Long
     
  On Error Resume Next
  Set oApp = GetObject("outlook.application")
  If Err <> 0 Then
    Set oApp = CreateObject("outlook.application")
  End If
  
  Set oNameSpace = oApp.GetNamespace("MAPI")
  
    Set oItem = oApp.CreateItem(olAppointmentItem)
    With oItem
      .Subject = "Slot booked"
      .Start = argDate + argTime
      .Duration = 30
      .AllDayEvent = False
      .Importance = olImportanceNormal
      .Location = "Workshop"
      .ReminderSet = False
      .Save
    End With
  
  Set oApp = Nothing
  Set oNameSpace = Nothing
  Set oItem = Nothing[/SIZE][/FONT]
[FONT=Courier New][SIZE=1]  CreateAppointment = True
  
 End Function[/SIZE][/FONT]
Now set the date and time where I've highlighted the code in red and run FindNextFreeSlot. It will look on that date starting from that time in half-hour increments for a free slot. If it finds one, it books it; if not, it warns you on-screen. (The slot is booked with fixed subject "Slot booked" and location "Workshop" but there's no reason why these values couldn't be passed in to the procedure along with the date and time.)

Hopefully you can understand the coding and maybe be able to use bits of it or the techniques it uses in your own program.
 
Upvote 0
Again, thank you very much!

I think that makes sense, I'll have a go at it over the weekend. I should be ok with it, it looks to me that all I have to do it modify the times, duration and where the information of the booking comes from. Perfect!

Regards,

Phil
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
VBA to create an Outlook calendar entry
Replies
7
Views
12K
Adman123
A
welshgasman
  • Question Question
Mailmerge from Excel sheet substituting phone number for 0
Replies
8
Views
780
welshgasman
welshgasman
C
  • Question Question
Excel Userform VBA - Value from Last Textbox not showing
Replies
3
Views
1K
dmt32
D
H
  • Question Question
Calendar Data to Input to Excel like Outlooks built in scheduling form
Replies
6
Views
891
HeyItsDizzy
H
LegendaryCue
  • Question Question
VBA Outlook 2013 Calendar to Excel
Replies
2
Views
2K
LegendaryCue
LegendaryCue

Forum statistics

Threads
1,224,595
Messages
6,179,798
Members
452,943
Latest member
Newbie4296

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top