Post to additional public calendar

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

Make an additional copy of the item and move it before you move the original:

Set myCopy = objAppt.Copy
myCopyMove objSomeOtherFolder

--
Sue Mosher, Outlook MVP
Author of Configuring Microsoft Outlook 2003
http://www.turtleflock.com/olconfig/index.htm
and Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
http://www.outlookcode.com/jumpstart.aspx

"Penny Miller" <Penny.Miller@co.chelan.wa.us> wrote in message news:%238$nkSJJHHA.2236@TK2MSFTNGP02.phx.gbl...
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

I know enough to be dangerous when it comes to coding, sorry. Would I place
it in the following locations?
' set user options
'public Time Off folder name and path
mstrToffFolder = "Public Folders/All Public Folders/Community
Development/Calendar - Code Enforcement"
mstrSomeOtherFolder = "Public Folders/All Public Folders/Community
Development/Calendar - Current Planning"
End Sub

' copy & move appointment to public folders
objAppt.Subject = Item.SenderName & " - " & Item.Body
Set objFolder = GetMAPIFolder(mstrToffFolder)
If Not objFolder Is Nothing Then
Set myCopy=objAppt.Copy
myCopyMove objSomeOtherFolder
objAppt.Move objFolder
End If


"Sue Mosher [MVP-Outlook]" <suemvp@outlookcode.com> wrote in message
news:%23Rlf4$JJHHA.1252@TK2MSFTNGP02.phx.gbl...
Make an additional copy of the item and move it before you move the
original:

Set myCopy = objAppt.Copy
myCopyMove objSomeOtherFolder

--
Sue Mosher, Outlook MVP
Author of Configuring Microsoft Outlook 2003
http://www.turtleflock.com/olconfig/index.htm
and Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
http://www.outlookcode.com/jumpstart.aspx

"Penny Miller" <Penny.Miller@co.chelan.wa.us> wrote in message
news:%238$nkSJJHHA.2236@TK2MSFTNGP02.phx.gbl...
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

That's a good start. You need to add a statement to return objSomeOtherFolder with the GetMAPIFolder() function.

--
Sue Mosher, Outlook MVP
Author of Configuring Microsoft Outlook 2003
http://www.turtleflock.com/olconfig/index.htm
and Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
http://www.outlookcode.com/jumpstart.aspx

"Penny Miller" <Penny.Miller@co.chelan.wa.us> wrote in message news:uNWjQFWJHHA.4712@TK2MSFTNGP04.phx.gbl...
>I know enough to be dangerous when it comes to coding, sorry. Would I place
> it in the following locations?
> ' set user options
> 'public Time Off folder name and path
> mstrToffFolder = "Public Folders/All Public Folders/Community
> Development/Calendar - Code Enforcement"
> mstrSomeOtherFolder = "Public Folders/All Public Folders/Community
> Development/Calendar - Current Planning"
> End Sub
>
> ' copy & move appointment to public folders
> objAppt.Subject = Item.SenderName & " - " & Item.Body
> Set objFolder = GetMAPIFolder(mstrToffFolder)
> If Not objFolder Is Nothing Then
> Set myCopy=objAppt.Copy
> myCopyMove objSomeOtherFolder
> objAppt.Move objFolder
> End If
>
>
> "Sue Mosher [MVP-Outlook]" <suemvp@outlookcode.com> wrote in message
> news:%23Rlf4$JJHHA.1252@TK2MSFTNGP02.phx.gbl...
> Make an additional copy of the item and move it before you move the
> original:
>
> Set myCopy = objAppt.Copy
> myCopyMove objSomeOtherFolder

>
> "Penny Miller" <Penny.Miller@co.chelan.wa.us> wrote in message
> news:%238$nkSJJHHA.2236@TK2MSFTNGP02.phx.gbl...
> 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
>
>