Solved

Add Appointment to Outlook Shared Calendar via Excel 2007 VBA

Posted on 2013-06-04
3
4,125 Views
Last Modified: 2016-09-06
I've found several scripts on the web, but they don't work or I can't get them to run and don't know why, even tho I'm fairly code-altering-literate.

A date in A1, sample 1/1/2014
A time in A2, sample 4:00 PM
Some text in A3, sample JoesPizza
Some text in A4, sample Training

I want to create an appointment in a shared Outlook Calendar with these 4 variables that will come from the worksheet named Appointment.

I've attached a sample file, and a picture of how I'd love the Outlook calendar entry to appear. Anything remotely close is hugely appreciated.
SampleEE.xlsm
0
Comment
Question by:Dreamboat
3 Comments
 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
ID: 39220667
Hi, Dreamboat.

I've added the code to the workbook(attached).  For anyone who doesn't want to download and open the workbook, here's teh code.

'Declare some constants
'On the next line enter the path to the shared calendar
Const CAL_PATH = ""

'Declare some variables
Dim excWks As Excel.Worksheet
Dim olkApp As Object, olkSes As Object, olkCal As Object, olkApt As Object

Sub Add2Outlook()
    'Get the worksheet
    Set excWks = Excel.ActiveWorkbook.Worksheets(1)
    
    'Connect to Outlook
    Set olkApp = CreateObject("Outlook.Application")
    Set olkSes = olkApp.GetNamespace("MAPI")
    olkSes.Logon olkApp.DefaultProfileName
    
    'Get the shared Outlook calendar
    Set olkCal = OpenOutlookFolder(CAL_PATH)
    
    'Create the appointment
    Set olkApt = olkCal.Items.Add
    With olkApt
        .Subject = excWks.Cells(3, 1) & " ~ " & excWks.Cells(4, 1)
        .Start = excWks.Cells(1, 1) & " " & CDate(excWks.Cells(2, 1))
        .Duration = 2
        .Save
    End With
    
    'Disconnect from Outlook
    olkSes.Logoff
    
    'Destroy objects to avoid memory leaks
    Set excWks = Nothing
    Set olkApt = Nothing
    Set olkCal = Nothing
    Set olkSes = Nothing
    Set olkApp = Nothing
End Sub

Function OpenOutlookFolder(strFolderPath As String) As Object
    ' Purpose: Opens an Outlook folder from a folder path.'
    ' Written: 4/24/2009'
    ' Author:  BlueDevilFan'
    ' Outlook: All versions'
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        bolBeyondRoot As Boolean
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = olkSes.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

Open in new window

SampleEE.xlsm
0
 
LVL 22

Author Comment

by:Dreamboat
ID: 39220986
I'll check it tomorrow. Thanks so much!!!
0
 

Expert Comment

by:David Jones
ID: 41785737
Hi David Lee.  I'm trying to achieve exactly what DreamBoat wanted to do (I appreciate this is a very old post now).  I've downloaded your spreadsheet and in the CAL_PATH constant I've entered \\Firstname.Lastname@ourdomain.org (Note: actual values replaced for security) because when I look at the location of my calendar that's what I see so I assume the location path for the shared calendar I want to add an appointment to will be the same format in our exchange environment.

When I run it the err.number in the function is -2147221233.

If I then change the constant so that it has my details in it the function returns no error and the code continues in to the With olkApt code.  But when I step it through it fails on the .Start = line with error "Object doesn't support this property or method"  I've tried replacing the cells lookup with a simple "15/09/2016 10:00" but I get the same error.

Any help at all would be gratefully received.  I have another variant of appointment creation code which works OK but only ever creates the appointment in my calendar, not the shared one.

Cheers
David
0

Featured Post

Free Tool: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

What does UTC stand for?  “Coordinated Universal Time” – Think of this as the true time on Planet Earth that never changes with the exception of minor leap seconds here and there to account for the changes in the planet's rotation.   What does th…
Do you use a spreadsheet like Microsoft's Excel?  Have you ever wanted to link out to a non excel file on your computer or network drive?  This is the way I found to do it!
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …

680 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question