Solved

Add Appointment to Outlook Shared Calendar via Excel 2007 VBA

Posted on 2013-06-04
3
3,969 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

Find Ransomware Secrets With All-Source Analysis

Ransomware has become a major concern for organizations; its prevalence has grown due to past successes achieved by threat actors. While each ransomware variant is different, we’ve seen some common tactics and trends used among the authors of the malware.

Join & Write a Comment

Check out this infographic on what you need to make a good email signature that will work perfectly for your organization.
This process describes the steps required to Import and Export data from and to .pst files using Exchange 2010. We can use these steps to export data from a user to a .pst file, import data back to the same or a different user, or even import data t…
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …
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: …

757 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

Need Help in Real-Time?

Connect with top rated Experts

22 Experts available now in Live!

Get 1:1 Help Now