Creating calendar entries in outlook from VB userform/excel

[philfloyduk]

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.

 

[Ruddles]

Well give me a shout if you get stuck - I shall check in every now and again.

 

[philfloyduk]

I need you already...

What reference do I need to add to the Outlook objects library? I've tested the 'FindNextFreeSlot' code and got an error, I assume because I've not made the reference.


Phil

 

[Ruddles]

Microsoft Outlook Objects Library.

 

[philfloyduk]

I already have that checked

 

[philfloyduk]

Stupid boy!

It's because I was doing one section at a time

Ignore me. It works perfectly, I'm delighted

 

[Ruddles]

 

[philfloyduk]

I don't suppose there's anything that can be done about this but it just took 43 seconds to create the entry at 7:00pm. I suppose it's because it's going back and forth checking the available slots but it's a painful wait when you've pressed a button and you're waiting for it, thought it'd crashed! Still, much more efficient than opening the calendar and pasting it yourself.

 

[Ruddles]

I don't suppose there's anything that can be done about this but it just took 43 seconds to create the entry at 7:00pm.

I'll take a look at it and make sure it isn't doing any more work than it needs to.

Are you likely to have more than one person trying to create entries at the same time?

 

[philfloyduk]

That'd be great. I've reverted to it opening the calendar and relying on the user to select the free slot. There's only one copy of the spreadsheet, one person will use it at a time. On that, how straight forward is it to make a spreadsheet work on two computers and be used at the same time? I'm not asking you to tell me how, just a general question.

Thanks


Phil

 

[Ruddles]

That'd be great. I've reverted to it opening the calendar and relying on the user to select the free slot

I found the problem: the code reads the entire calendar for each appointment slot it checks, so checking the 9am slot takes twice as long as checking the 8.30am slot, checking the 9.30am slot takes three times as long, etc.

The new code looks like this: BookNextFreeSlot is a sample of the code you need to produce to check for the next free slot on a given day, and if one exists between opening time and closing time, book it with the specified duration:-

[FONT=Fixedsys]Option Explicit[/FONT]
[FONT=Fixedsys][/FONT] 
[FONT=Fixedsys]Sub BookNextFreeSlot()[/FONT]
[FONT=Fixedsys][/FONT] 
[FONT=Fixedsys]  Dim dtDateToCheck As Date
  Dim dtTimeToCheck As Date
  Dim iDuration As Integer
  Dim dtLastAppointment As Date
  
  Dim dtNextFreeSlot As Date
  
  dtDateToCheck = DateValue("[COLOR=red][B]26-Feb-2011[/B][/COLOR]")
  dtTimeToCheck = TimeValue("[COLOR=darkorange][B]08:30:00[/B][/COLOR]")
  iDuration = [/FONT][FONT=Fixedsys][COLOR=magenta][B]30
[/B][/COLOR]  dtLastAppointment = TimeValue("[COLOR=blue][B]17:30:00[/B][/COLOR]")
  
  dtNextFreeSlot = FindNextFreeSlot(dtDateToCheck + dtTimeToCheck, iDuration)
    
  If dtNextFreeSlot > dtDateToCheck + dtLastAppointment + TimeSerial(0, 0, 1) Then
    MsgBox "No free slots today!", vbOKOnly + vbExclamation
  Else
    If CreateAppointment(dtNextFreeSlot, iDuration) Then
      MsgBox "Appointment for " & Format(dtNextFreeSlot, "hh:nn") _
           & " on " & Format(dtNextFreeSlot, "d-mmm-yyyy") & " created", _
           vbOKOnly + vbInformation
    Else
      MsgBox "Problem creating appointment for " & Format(dtNextFreeSlot, "hh:nn") _
           & " on " & Format(dtNextFreeSlot, "d-mmm-yyyy"), vbOKOnly + vbExclamation
    End If
  End If[/FONT]
[FONT=Fixedsys][/FONT] 
[FONT=Fixedsys]End Sub[/FONT]

FindNextFreeSlot is the procedure which returns the next free slot. It only reads the calendar once, storing the existing appointments for the specified day in an array, and then checks for free slots in the (very small and very fast) array.

[FONT=Fixedsys]Option Explicit[/FONT]
[FONT=Fixedsys][/FONT] 
[FONT=Fixedsys]Public Function FindNextFreeSlot(ByVal argCheckDateTime As Date, ByVal argDuration As Integer) As Date[/FONT]
[FONT=Fixedsys][/FONT] 
[FONT=Fixedsys]  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
  
  Dim aStore() As Date
  Dim iPtr As Integer
  Dim bFound As Boolean
  
  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
  
  Set oNameSpace = oApp.GetNamespace("MAPI")
  Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)
  
  ReDim aStore(0) As Date
  
  For Each oObject In oFolder.Items
    If oObject.Class = olAppointment Then
      Set oApptItem = oObject
      If Int(oApptItem.Start) = Int(argCheckDateTime) Then
        ReDim Preserve aStore(UBound(aStore) + 1) As Date
        aStore(UBound(aStore)) = oApptItem.Start
      End If
    End If
  Next oObject
  
  FindNextFreeSlot = argCheckDateTime
  Do
    iPtr = 1
    bFound = False
    For iPtr = 1 To UBound(aStore)
      If Format(aStore(iPtr), "dd/mm/yyyy hh:nn:ss") = Format(FindNextFreeSlot, "dd/mm/yyyy hh:nn:ss") Then
        bFound = True
        Exit For
      End If
    Next iPtr
    If bFound = False Then Exit Do
    FindNextFreeSlot = FindNextFreeSlot + TimeSerial(0, argDuration, 0)
    DoEvents
  Loop
  
  Set oApp = Nothing
  Set oNameSpace = Nothing
  Set oApptItem = Nothing
  Set oFolder = Nothing
  Set oObject = Nothing
   
End Function[/FONT]

And a slightly modified version of CreateAppointment:-

[FONT=Fixedsys]Option Explicit[/FONT]
[FONT=Fixedsys][/FONT] 
[FONT=Fixedsys]Public Function CreateAppointment(ByVal argDateTime As Date, ByVal argDuration As Integer) As Long[/FONT]
[FONT=Fixedsys][/FONT] 
[FONT=Fixedsys]  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 = argDateTime
      .Duration = argDuration
      .AllDayEvent = False
      .Importance = olImportanceNormal
      .Location = "Workshop"
      .ReminderSet = False
      .Save
    End With
  
  Set oApp = Nothing
  Set oNameSpace = Nothing
  Set oItem = Nothing[/FONT]
[FONT=Fixedsys]  CreateAppointment = True
  
 End Function[/FONT]

Hopefully you can put this lot together! Please let me know if it's any faster than the previous version?