Solved

Add Appointment to Outlook Shared Calendar via Excel 2007 VBA

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

Complete VMware vSphere® ESX(i) & Hyper-V Backup

Capture your entire system, including the host, with patented disk imaging integrated with VMware VADP / Microsoft VSS and RCT. RTOs is as low as 15 seconds with Acronis Active Restore™. You can enjoy unlimited P2V/V2V migrations from any source (even from a different hypervisor)

Question has a verified solution.

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

Are you unable to connect or configure Hotmail email account in Microsoft Outlook 2010, 2007? Or Outlook.com emails are not downloading to Outlook? Lets’ see the problem and resolve Outlook Connector error syncing folder hierarchy (0x8004102A).
Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

829 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