Add To Outlook Calendar UDF
September 10, 2008 • JP • 15 Comments • Rate This Article
Here is a simple UDF that adds an appointment to your Outlook calendar. It can be used from Excel or VBA, and it should be usable from Access as well (untested). It uses another concept I've also been trying out: checking functions to make sure they are successful by using Boolean return values. I believe I read this in Professional Excel Development, but I'd be hard pressed to find the page number. 
It's actually quite simple. Just create your function and tell it to return a Boolean value, which you then use to test if the function completed its task. It's part of the encapsulation/modularization habit I've been working on.
For example:
On Error Resume Next
Range(Rng).Value = lNum
On Error Goto 0
If Err = 0 Then
AddToRange = True
End If
End Function
The above UDF accepts a Range object and Long as arguments, and returns a Boolean value (True or False) depending on the success or failure of the internal operation. It works like this:
bIsDone = AddToRange("A1", 5)
or
' your code here
End If
In other words, the function carries out its operation and returns True or False to the calling sub. You just have to tell the function how to communicate that it was successful (or failed). If we were able to insert the number 5 into Range("A1"), it returns True. This may have nothing to do with the actual function's operation, we just need a way to communicate back to the calling sub whether our function did what it was supposed to do.
Now here's the real sub. We'll use late-binding to ensure the code can literally be cut and pasted anywhere. Don't forget to include the GetOutlookApplication function below as well.
On Error GoTo ErrorHandler
Dim olApp As Object
Dim objNewAppt As Object
'get reference to Outlook
Set olApp = GetOutlookApplication
If olApp Is Nothing Then
MsgBox "Cannot access Outlook. Exiting now", vbInformation
GoTo ErrorHandler
End If
Set objNewAppt = olApp.createitem(1) ' 1 is the constant for olAppointmentItem when using late-bound code, or VBScript
With objNewAppt
.Start = dteDate & " " & dteStart
.End = dteDate & " " & dteEnd
.Subject = strSubject
.Location = strLoc
.reminderset = True
.ReminderMinutesBeforeStart = 30
.Save
End With
AddToCalendar = True
GoTo ExitProc
ErrorHandler:
AddToCalendar = False
ExitProc:
Set olApp = Nothing
Set objNewAppt = Nothing
End Function
On Error Resume Next
Set GetOutlookApplication = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set GetOutlookApplication = CreateObject("Outlook.Application")
End If
On Error GoTo 0
End Function
This function may be used in VBA, or directly in the worksheet. Just be careful when using it in an Excel worksheet, because it will recalculate and you'll end up with multiple duplicate appointments (unless you happen to change the parameters before every recalculation).
Also note there are two different ways to call this function, depending on where you are calling it. If you call it from VBA, you must enclose the date (and time, which is technically stored as a Date) arguments in hash marks, like this:
If AddToCalendar(#10/11/2008#, "My Meeting", "My desk", #10:00:00 AM#, #11:00:00 AM#) Then
MsgBox "appointment was added"
End If
End Sub
If you are doing it from the worksheet, all of the arguments must be in quotes:
Since the function returns a Boolean value, the worksheet will show "TRUE" in the cell, if the function was successful, and "FALSE" if not.
The GetOutlookApplication function returns a reference to the Outlook object to the calling function. Notice that in this case, we don't set up a Boolean return variable, because we want to set an actual object reference, not just test to see if our function was successful.
(No Ratings Yet)
Loading ...What now?
Subscribe To The Blog
Email This Article
Follow Me On Twitter
My Facebook Page
Or just keep reading:
I'm just an average guy who writes VBA code for a living. This is my personal blog. Excel and Outlook are my thing, with a sprinkle of Access and Word here and there. Follow this space if you want to learn more about VBA. Keep Reading »
Previous Post: Excel Blogs List and OPML Feeds List
Next Post: Where were you?
Hi JP,
I had written a fairly similar routine myself with which I want to loop through an Excel sheet containing a nummber of events, planned for various dates. It all works fine when I have a session of Outlook already running (using the GetObject command), but when I try it without an active Outlook session (CreateObject) it somehow only creates the first event it stumbles upon. The code looks like this:
Set myOlApp = GetObject(, "Outlook.Application")
If Err.Number 0 Then Set myOlApp = CreateObject("Outlook.Application")
End If
Set myItem = myOlApp.CreateItem olAppointmentItem)
With myItem
.Subject = event
.Start = strDate + TimeValue(strStartTime)
.Duration = strDuration
.Save
.Close (olSave)
End With
Set myItem = Nothing
Set myOlApp = Nothing
I also wonder why you don't use the Item.Close (olSave) command ? When I leave it out, it only places each current event in the calendar and deletes the previuosly planned, as if the myItem contents are replaced with every run.
Any suggestions ?
I don't recall why I use Save instead of Close. It makes more sense to call the Close Method with the olSave constant.
But how are you declaring myOlApp? If you are using late bound code (i.e. declaring "As Object"), you can't use Outlook's built in constants. So you'll need to replace "olAppointmentItem" with the number 1, and replace olSave with the number 0.
Otherwise I don't see anything wrong with the code you've posted, try stepping through it with Outlook open and closed and see what happens.
My programming experience is very minimal.
A co-worker asked me find a way to add dates and subjects from excel to his outlook calendar. I found your code, made some minor changes and inserted it where i needed (Worked GREAT). However it adds the event everytime. I've been trying things for 2 days now with no luck. My question… Is there a way to go to that date and see if that event exists already? If it does, i don't want it to add the event, if not then i want it added. I've included my code so you can see what is going on
'Declaring Varables
Dim TheItem As String
Dim DueDate As Date
Dim Startcell As String
Dim olDate As Date
Dim olItem As String
'Adding the new tasks to Outlook Calander
Range("A2").Select 'Sets Starts Cell
While (IsEmpty(ActiveCell.Value) = False)
TheItem = ActiveCell.Value 'Sets Subject
DueDate = ActiveCell.Offset(0, 5).Value 'Sets Date
'Need a Function that goes to DueDate and Sets the task
'if any equal to olItem, If Item exists do nothing
'If item doesn't exist make it exist
olItem = GetObject("Outlook.Application", "Subject")
If (olItem TheItem And DueDate <= Date) Then
Run (AddToCalendar(DueDate, TheItem)) 'Adds to Calendar
ActiveCell.Offset(1, 0).Select
MsgBox ("If you see this it worked")
Else
ActiveCell.Offset(1, 0).Select
End If
Wend
'Letting the user know it worked
MsgBox ("Your Outlook Calendar has now been updated with the new tasks")
End Sub
Function AddToCalendar(dteDate As Date, strSubject As String) As Boolean
On Error GoTo ErrorHandler
Dim olApp As Object
Dim objNewAppt As Object
'get reference to Outlook
Set olApp = GetOutlookApplication
If olApp Is Nothing Then
MsgBox "Cannot access Outlook. Exiting now", vbInformation
GoTo ErrorHandler
End If
Set objNewAppt = olApp.createitem(1) ' 1 is the constant for olAppointmentItem when using late-bound code, or VBScript
With objNewAppt
.Start = dteDate & " " & dteStart
.Subject = strSubject
.reminderset = True
.Save
End With
AddToCalendar = True
GoTo ExitProc
ErrorHandler:
AddToCalendar = False
ExitProc:
Set olApp = Nothing
Set objNewAppt = Nothing
End Function
Function GetOutlookApplication()
On Error Resume Next
Set GetOutlookApplication = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set GetOutlookApplication = CreateObject("Outlook.Application")
End If
On Error GoTo 0
End Function
Hi Rob,
What you want is a separate function that checks for an existing appointment with the same date and subject, before adding it. Something like
Run (AddToCalendar(DueDate, TheItem))
End If
Where AlreadyExists is a function that returns true or false. I coded something from memory but this should get you started.
' returns true if the calendar item with the specified subject
' and on the specified date already exists in the calendar
'get reference to Calendar items on the specified date
Dim olApp As Object
Dim olNS As Object
Dim CalendarItems As Object
Dim StringToCheck As String
Dim appt As Object
Set olApp = GetOutlookApplication ' see GetOutlookApplication Function
Set olNS = olApp.Getnamespace("MAPI")
StringToCheck = "[StartDate] >= " & Quote(dteDate)
Set CalendarItems = olNS.GetDefaultFolder(9).Items.Restrict(StringToCheck) 'olFolderCalendar
For Each appt in CalendarItems
If appt.Subject = strSubject Then
AlreadyExists = True
Goto ExitProc
End If
Next appt
ExitProc:
Set olNS = Nothing
Set CalendarItems = Nothing
Set olApp = Nothing
End Function
Function Quote(MyText)
' from Sue Mosher's excellent book "Microsoft Outlook Programming"
Quote = Chr(34) & MyText & Chr(34)
End Function
I keep getting a runtime error for…
Set CalendarItems = olNS.GetDefaultFolder(olFolderCalendar).Items.Restrict(StringToCheck)
I've tried many different things, But i keep getting error there.
What is a "MAPI"? As in…
Set olNS = olApp.Getnamespace("MAPI")
I remember seeing that someother time in one of my searches.
Any advice?
Thanks
My mistake, change "olFolderCalendar" to the number 9 and it should work.
Thanks JP i managed to get it to work.
I added msgboxs to see where the problem was, turns out it wasn't going in to the For statement. In the end i removed .Restrict(StringToCheck) from
Set CalendarItems = olNS.GetDefaultFolder(9).Items.Restrict(StringToCheck) 'olFolderCalendar
Now it works great.
Thanks again
~Rob
Please could you make a working copy available for me to download so I can understand how to use on my excel worksheet as I do not fully understand how to do this.
Thanks in advance
Mark,
At the bottom of the post there's a link "Download a working sample here."
How can the code be adjusted to add the item to a calendar in another folder and not the default calendar??
You'll need to change
to
where "Some Folder Name" is the name of the calendar. This is assuming you want a calendar in a public folder.
Hi
How do I get the tasks to show up in the Calendar view, is there a way to set up a procedure that creates an appointment if a task has a due date?
Thanks
You can't show tasks in a calendar view, only appointments/meetings.
Do you want something that goes through the Tasks folder and adds appointments?
Yes if possible automatically when you create a task that has a due date and time, and doesn't replicate any other calendar appointments that are already there.
Thanks in advance
Tasks have reminder times, not due times.
I'm curious, if you have a task with a reminder set, why do you need an appointment? It's just another reminder.
How will the code decide what time to make the appointment? Should it start when the task is due, or END when the task is due, or some other time?