Post to additional public calendar

P

Penny Miller

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
 
S

Sue Mosher [MVP-Outlook]

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

and Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers


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
 
P

Penny Miller

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


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

and Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers


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
 
S

Sue Mosher [MVP-Outlook]

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

and Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Vacation Calendar 5
VBA to populate custom field on custom form 0
Outlook 2000 VBA Macro Advice 1
objTargetFolder can't move item 2
how can i know the complete path to an outlook folder ? 8
Operation Failed, object could be not be found - Can't find the fo 2
Adding an entry to a Calendar in a shared public folder with VBA 5
Set Item.SaveSentMessageFolder = objFolder run time error '424' 13

Top