Questionboy
New Member
- Joined
- Feb 2, 2012
- Messages
- 9
I've been using a macro i put together some time ago (with the help of code on line) that creates appointments in my default calender.
I have been asked to adapt it so that multiple users can use it to populate a sharpoint calender via outlook. When the calender is linked to outlook it appears under the "other Calendars" heading in outlook. the actual name of the calender is pulled from a cell that is referenced bellow as arrCal.
I'm wondering if someone could help me in adapting the below code to allow for this to happen.
I have been asked to adapt it so that multiple users can use it to populate a sharpoint calender via outlook. When the calender is linked to outlook it appears under the "other Calendars" heading in outlook. the actual name of the calender is pulled from a cell that is referenced bellow as arrCal.
I'm wondering if someone could help me in adapting the below code to allow for this to happen.
VBA Code:
Public Sub CreateOutlookApptz()
Call Finalise
Call Clear
Sheets("Log").Select
' On Error GoTo Err_Execute
Dim olApp As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
Dim blnCreated As Boolean
Dim olNs As Outlook.Namespace
Dim CalFolder As Outlook.MAPIFolder
Dim subFolder As Outlook.MAPIFolder
Dim arrCal As String
Dim i As Long
On Error Resume Next
Set olApp = Outlook.Application
If olApp Is Nothing Then
Set olApp = Outlook.Application
blnCreated = True
Err.Clear
Else
blnCreated = False
End If
On Error GoTo 0
Set olNs = olApp.GetNamespace("MAPI")
Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
i = 3
Do Until Trim(Cells(i, 1).Value) = ""
arrCal = Cells(i, 1).Value
Set subFolder = CalFolder.Folders(arrCal)
If Trim(Cells(i, 11).Value) = "" Then
Set olAppt = subFolder.ItemS.Add(olAppointmentItem)
'MsgBox subFolder, vbOKCancel, "Folder Name"
With olAppt
'Define calendar item properties
.Start = Cells(i, 6) + Cells(i, 7) '+ TimeValue("9:00:00")
.End = Cells(i, 8) + Cells(i, 9) '+TimeValue("10:00:00")
.Subject = Cells(i, 2)
.Location = Cells(i, 3)
.Body = Cells(i, 4)
.BusyStatus = olFree
.ReminderMinutesBeforeStart = Cells(i, 10)
.ReminderSet = False 'Change to True if reminders are required
.Categories = Cells(i, 5)
.Save
End With
Cells(i, 11) = "Imported"
End If
i = i + 1
Loop
Set olAppt = Nothing
Set olApp = Nothing
ThisWorkbook.Save
Exit Sub
Err_Execute:
MsgBox "An error occurred - Exporting items to Calendar."
Call Clear
Sheets("InProcess").Select
MsgBox "Your dates have been added to the calender"
End Sub