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:
Function AddToRange(Rng As Excel.Range, lNum As Long) As Boolean 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:
Dim bIsDone As Boolean
bIsDone = AddToRange("A1", 5)
or
If AddToRange("A1", 5) Then
' 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.
Function AddToCalendar(dteDate As Date, strSubject As String, strLoc As String, dteStart As Date, dteEnd As Date) 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 .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
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
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:
Sub SaveAppt() 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:
=AddToCalendar("10/11/2008","My topic","My location","10:00 AM","11:00 AM")
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.
About JP
15 Comments:
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:
On Error Resume Next 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 = NothingI 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
Sub Button1_Click() '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 FunctionHi 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
Where AlreadyExists is a function that returns true or false. I coded something from memory but this should get you started.
Private Function AlreadyExists(dteDate As Date, strSubject As String) As Boolean ' 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 FunctionI 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
Set objNewAppt = olApp.GetNamespace("MAPI").GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders("Some Folder Name").Items.Addwhere "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?