I have created a form that is a time off request so when it is sent to the supervisor she/he can either approve or deny the employees time off. If she/he approves the time off, it sends the employee a message stating so and allows them to click and drag to their own calendar. Also, it will copy this information and place it on a public calendar for their division. If she/he deny's this request, it sends a message stating so and does nothing else. So far it works like a charm!

The problem is that the department head would like it to not only to post to the divisions calendar but also the departments global calendar and I'm not sure of the correct code to use. Can someone lead me in the right direction?

Here is my code;

Option Explicit

Dim mstrToffFolder ' public Time Off folder

Const olOutOfOffice = 3
Const olAppointmentItem = 1
Const olByValue = 1

Sub InitOpts()
' set user options

'public Time Off folder name and path
mstrToffFolder = "Public Folders/All Public Folders/Community Development/Calendar - Code Enforcement"
End Sub

Function Item_Open()
If Item.Size 0 Then
InitOpts
End If
End Function

Function Item_CustomAction(ByVal Action, ByVal NewItem)
Dim objAppt
Dim objAttachment
Dim objFolder
Dim dteStart
Dim dteEnd

Select Case Action.Name
Case "Approve"
' create appointment for user to save to calendar
dteStart = _
Item.UserProperties("TimeOffStart")
dteEnd = _
Item.UserProperties("TimeOffEnd")
Set objAppt = _
Application.CreateItem(olAppointmentItem)
With objAppt
..Start = dteStart
..End = dteEnd
..ReminderSet = False
..Subject = Item.Subject
..Body = Item.Body
..AllDayEvent = False
..BusyStatus = olOutOfOffice
End With
objAppt.Save
Set objAttachment = NewItem.Attachments.Add( _
objAppt, olByValue, , _
"Your Time Off")
NewItem.Body = "Your time off has been " & _
"approved. Drag the attached " & _
"Appointment to your Calendar. " & _
"Or, open it, then use File | Copy to Folder." & vbCrLf & vbCrLf
' move appointment to public folder
objAppt.Subject = Item.SenderName & " - " & Item.Body
Set objFolder = GetMAPIFolder(mstrToffFolder)
If Not objFolder Is Nothing Then
objAppt.Move objFolder
End If

Case Else
'do nothing special for other actions
End Select
' dereference objects
Set objAppt = Nothing
Set objAttachment = Nothing
Set objFolder = Nothing
End Function


Function GetMAPIFolder(strName)
Dim objApp
Dim objNS
Dim objFolder
Dim objFolders
Dim arrName
Dim objExpl
Dim I
Dim blnFound

Set objApp = Application
Set objNS = objApp.GetNamespace("MAPI")
arrName = Split(strName, "/")
Set objFolders = objNS.Folders
blnFound = False
For I = 0 To UBound(arrName)
For Each objFolder In objFolders
If objFolder.Name = arrName(I) Then
Set objFolders = objFolder.Folders
blnFound = True
Exit For
Else
blnFound = False
End If

Next
If blnFound = False Then
Exit For
End If

Next
If blnFound = True Then
Set GetMAPIFolder = objFolder
Else
Set GetMAPIFolder = Nothing
End If

Set objApp = Nothing
Set objNS = Nothing
Set objFolder = Nothing
Set objFolders = Nothing
Set objExpl = Nothing

End Function