?
Solved

Add Appointment to Outlook Shared Calendar via Excel 2007 VBA

Posted on 2013-06-04
3
Medium Priority
?
4,249 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
3 Comments
 
LVL 76

Accepted Solution

by:
David Lee earned 2000 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

The Eight Noble Truths of Backup and Recovery

How can IT departments tackle the challenges of a Big Data world? This white paper provides a roadmap to success and helps companies ensure that all their data is safe and secure, no matter if it resides on-premise with physical or virtual machines or in the cloud.

Question has a verified solution.

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

Access developers frequently have requirements to interact with Excel (import from or output to) in their applications.  You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
In Part II of this series, I will discuss how to identify all open instances of Excel and enumerate the workbooks, spreadsheets, and named ranges within each of those instances.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.
CodeTwo Sync for iCloud (http://www.codetwo.com/sync-for-icloud?sts=6554) automatically synchronizes your Outlook 2016, 2013, 2010 or 2007 folders with iCloud folders available via iCloud Control Panel. This lets you automatically sync them with…
Suggested Courses

752 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