Changing Default Outlook folder using VBA

Hello Experts,

I have the following function which is adding an Outlook calendar appointment event from Microsoft Access using late binding. It is working just fine but I would like to change the location to a shared calendar folder called "\\Calendar\Shared".

Could someone show me how that would be accomplished?

Public Sub ScheduleInOutlookCalendar(lngSONum As Long, strCustName As String, datApptDate As Date, datApptTime, datPromDate As Date, _
     datPromTime As Date, lngEstTime As Long, strYearMakeModel As String, strTech As String, strPriority As String, strMsg As String, _
     strContactNumbers As String, strParts As String, strLabour As String, dblTotHrs As Double, dblActHrs As Double)

    Dim olApp As Object
    Dim olNs As Object
    Dim olApt As Object
    Dim olBusy As Object
    Dim olTentative As Object
    Dim strEstTime As String
    Dim strApptTime As String
    Dim lngRemTime As Long
    'Convert the estimated time in minutes to the correct format
    strEstTime = Format(Int(([lngEstTime]) / 60), "00") & ":" & Format(([lngEstTime] Mod 60), "00") & ":00"
    strApptTime = Format(datApptTime, "HH:MM:SS")

    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")

    If Err.Number = 429 Then
        Set olApp = CreateObject("Outlook.application")
    End If

    On Error GoTo 0

    Set olNs = olApp.GetNamespace("MAPI")

    If olApp.ActiveExplorer Is Nothing Then
        olApp.Explorers.Add _
            (olNs.GetDefaultFolder(9), 0).Activate
        Set olApp.ActiveExplorer.CurrentFolder = _
    End If
    'Dim olApt As Outlook.AppointmentItem
    Set olApt = olApp.CreateItem(1)

    With olApt
        .start = datApptDate + TimeValue(strApptTime)
        .End = .start + TimeValue(strEstTime)
        .Subject = "SO: " & lngSONum & ";  Customer: " & strCustName & ";  Vehicle: " & strYearMakeModel & ""
        .Location = "Tech: " & strTech
        'Mod_D0102_2013(3) - added Actual Hours
        'Mod_D1231_2012(8) - added more SO details
        .Body = "Customer: " & strCustName & vbCrLf & _
                "Vehicle: " & strYearMakeModel & vbCrLf & _
                "Priority: " & strPriority & vbCrLf & _
                "Estimated Hours: " & dblTotHrs & vbCrLf & _
                "Actual Hours: " & dblActHrs & vbCrLf & _
                "Assigned Technician: " & strTech & vbCrLf & vbCrLf & _
                "Contact Numbers: " & strContactNumbers & vbCrLf & _
                "Promised Date: " & datPromDate & vbCrLf & _
                "Promised Time: " & datPromTime & vbCrLf & vbCrLf & _
                "Parts Information: " & strParts & vbCrLf & vbCrLf & _
                "Labour Information: " & strLabour & vbCrLf & vbCrLf & _
                "Notes: " & strMsg
        'Mod_D1231_2012(9) - new
        If strPriority = "High" Then
            .importance = 2
            .importance = 0
        End If
        '.ReminderMinutesBeforeStart = 120
        '.MeetingStatus = 0
        .BusyStatus = 0
        '.ReminderSet = True
    End With
    Set olApt = Nothing
    Set olNs = Nothing
    Set olApp = Nothing

End Sub
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Chris BottomleySoftware Quality Lead EngineerCommented:
olns.folders("Calendar").folders("Shared") or

DonGarryAuthor Commented:
Hi Chris,

I tried both of your suggestions and it still loads into the default calendar...

Any other suggestions?
Chris BottomleySoftware Quality Lead EngineerCommented:
You can use .move within the 'With olApt' construct i.e.

.move olNs.GetDefaultFolder(9).folders("Shared")

IT Pros Agree: AI and Machine Learning Key

We’d all like to think our company’s data is well protected, but when you ask IT professionals they admit the data probably is not as safe as it could be.

DonGarryAuthor Commented:
Thanks Chris,

The .move you suggested moves the item into the 'shared' folder successfully.

If the appointment is in the 'default' folder, I can access it programmatically to see if the start time has changed or if it has been deleted so then am able to synchronize back to our database.

When we move it to the 'shared' folder is there a way of getting access to it?
Chris BottomleySoftware Quality Lead EngineerCommented:
It is as accessible in the 'shared' folder as it is anywhere else, you just need to address the correct folder.

DonGarryAuthor Commented:
Thanks Chris,

I guess I'm back to my fundamental problem of not knowing how to gain access to the 'Shared' Calendar programmatically even thougth your
.move olNs.GetDefaultFolder(9).folders("Shared") suggestion worked just fine.
Chris BottomleySoftware Quality Lead EngineerCommented:
What is it you want to do with the folder since as I say

accesses the folder in question just as
accesses the default calendar.

DonGarryAuthor Commented:
Hi Chris,

Thank you for your patience!!

OK, I'm able to open up the shared calendar by using olNs.GetDefaultFolder(9).folders("Shared")

When I used Set olApt = olApp.CreateItem(1) it still adds an appointment to the default there a way I can add the appointment directly into the 'Shared' Calendar?

Chris BottomleySoftware Quality Lead EngineerCommented:
createitem always creates in the default folder however you can create in sub folders via the add method for example:

Set olApt = olApp.Session.GetDefaultFolder(9).Folders("Shared").Items.Add


Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
DonGarryAuthor Commented:
Hi Chris,


Thank you for taking the time to assist me!

It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Office Productivity

From novice to tech pro — start learning today.