• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 4375
  • Last Modified:

Add Appointment to Outlook Shared Calendar via Excel 2007 VBA

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
Dreamboat
Asked:
Dreamboat
1 Solution
 
David LeeCommented:
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
 
DreamboatAuthor Commented:
I'll check it tomorrow. Thanks so much!!!
0
 
David JonesCommented:
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

VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

Tackle projects and never again get stuck behind a technical roadblock.
Join Now