Excel VBA macro to outlook shared agenda

[mikeyy30]

Hi Guys,

I'm trying to figure out what im doing wrong with my macro:

The appointments need to go in the testagenda calendar.
Now the appointments go in my own calendar and i get blank appointments on the today date in de test agenda.

Can anyone see where my fault is?


Thanks!



VBA:

Sub MaakAfspraken()

Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olDefualtFolder As Outlook.Folder
Dim olDestinationFolder As Outlook.Folder
Dim olFolders As Outlook.Folders
Dim olItems As Outlook.Items
Dim olAppt As Outlook.AppointmentItem

Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")

Set olFldr = olApp.GetNamespace("MAPI").GetDefaultFolder(9).Folders("testagenda")
Set olAppt = olFldr.Items.Add

' Set the Defualt Folder to the appropriate folder type
Set olDefualtFolder = olNS.GetDefaultFolder(olFolderCalendar)

'get the defualt calenders collection of sub folders
Set olFolders = olDefualtFolder.Folders

'get the specific destination folder
Set olDestinationFolder = olFolders.Item("testagenda")

'get the collection of items in destination folder
Set olItems = olDestinationFolder.Items

' Add an item to the collection
Set olAppt = olItems.Add(olAppointmentItem)

' Add an item to the collection
Set olAppt = olItems.Add(olAppointmentItem)



Range("A9").Select
'olApp.visbible = yes
Do
Set olApt = olApp.CreateItem(olAppointmentItem)
With olApt
.Start = ActiveCell.Value + ActiveCell.Offset(0, 1).Value
If Not IsEmpty(ActiveCell.Offset(0, 3).Value) Then
.End = .Start + ActiveCell.Offset(0, 3).Value
Else
.End = ActiveCell.Value + ActiveCell.Offset(0, 2).Value
End If
.Subject = ActiveCell.Offset(0, 4).Value
.Location = ActiveCell.Offset(0, 5).Value
If Not IsEmpty(ActiveCell.Offset(0, 6).Value) Then
olApt.MeetingStatus = olMeeting
.RequiredAttendees = ActiveCell.Offset(0, 6).Value
.OptionalAttendees = ActiveCell.Offset(0, 7).Value
End If
.Body = ActiveCell.Offset(0, 8).Value
If ActiveCell.Offset(0, 9).Value = "Bezet" Then
.BusyStatus = olBusy
ElseIf ActiveCell.Offset(0, 9).Value = "Vrij" Then
.BusyStatus = olFree
ElseIf ActiveCell.Offset(0, 9).Value = "Voorlopig bezet" Then
.BusyStatus = olTentative
ElseIf ActiveCell.Offset(0, 9).Value = "Niet aanwezig" Then
.BusyStatus = olOutOfOffice
ElseIf IsEmpty(ActiveCell.Offset(0, 9).Value) Then
.BusyStatus = olBusy
End If
If Not IsEmpty(ActiveCell.Offset(0, 10).Value) Then
.ReminderMinutesBeforeStart = ActiveCell.Offset(0, 10).Value
Else
.ReminderMinutesBeforeStart = 60
End If
.ReminderSet = True
.Save
.Send
End With
Set olApt = Nothing
ActiveCell.Offset(1, 0).Select
Loop Until IsEmpty(ActiveCell)

Range("A9").Select


'Set reminder for 1 day before.
olAppt.ReminderMinutesBeforeStart = 1440
olAppt.AllDayEvent = True
olAppt.Save

MsgBox "You have just updated the outlook calendar. ", vbInformation, Title:="Outlook Calendar Updated"

' move item to desired destination folder - no longer needed
' olAppt.Move olDestinationFolder

SubExit:
Set olAppt = Nothing
Set olDefualtFolder = Nothing
Set olFolders = Nothing
Set olDestinationFolder = Nothing

Set olNS = Nothing
Set olApp = Nothing

Exit Sub

SubError:
MsgBox "Error Number: " & Err.Number & " - " & Err.Description
Resume SubExit

End Sub

https://dl.dropboxusercontent.com/u/104938133/1.xlsm