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" wrote in message ...
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]" wrote in message
...
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" wrote in message
...
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" wrote in message ...
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]" wrote in message
...
Make an additional copy of the item and move it before you move the
original:

Set myCopy = objAppt.Copy
myCopyMove objSomeOtherFolder


"Penny Miller" wrote in message
...
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