Here's the code -- this was created by one of our former employees:
-----------------------
Option Explicit
Const olFolderCalendar = 9
Const olOutOfOffice = 3
Const olFree = 0
Const olAppointmentItem = 1
Const olByValue = 1
Const olBCC = 3
Const olCC = 2
'Public Vacation Folder Path
Dim boolIsNew
Function Item_Open()
Dim strManager
Dim objPage
Dim objCtrl
Dim objRecip
'Stop
'Check to see if this is a new item
If Item.Size = 0 Then
boolIsNew = True
' try to get the name of my manager
strManager = GetMyManagerName()
If strManager <> vbNullString Then
Set objRecip = Item.Recipients.Add(strManager)
objRecip.Resolve
If objRecip.Resolved Then
Set objPage =
Item.GetInspector.ModifiedFormPages("Message")
Set objCtrl = objPage.Controls("cbToType")
objCtrl.SetFocus
End IF
End If
Else
boolIsNew = False
End If
'Stop
'Check the Approved Action
If Item.UserProperties.Find("Approved") <> "No Action" Then
Item.Actions.Item(5).Enabled = False
Item.Actions.Item(6).Enabled = False
End If
'MsgBox boolIsNew
End Function
Function Item_CustomAction(ByVal Action, ByVal NewItem)
Dim vacStart
Dim vacEnd
Dim toType
Dim vacHours
Dim vacComments
Dim strVacFolder
Dim hrAddress
Dim objNS
Dim vacApproverName
Dim vacApprovedName
Set objNS = Application.GetNamespace("MAPI")
'Stop
vacApproverName = objNS.CurrentUser.Name
vacApprovedName = Item.SenderName
hrAddress = "Corporate Payroll" '"Nancy Tarter" "Shane Kempton" '
strVacFolder = "Public Folders\All Public Folders\vacations"
vacStart = Item.UserProperties.Find("Vacation Start")
vacEnd = Item.UserProperties.Find("Vacation End")
toType = Item.UserProperties.Find("ToType")
vacHours = Item.UserProperties.Find("Time Off Hours")
vacComments = Item.ItemProperties.Item("Body")
Select Case Action.Name
Case "Approve"
'Make an Appointment
'Stop
Call AddAppointment(strVacFolder, vacStart, vacEnd,
toType, NewItem)
NewItem.Body = "Your time off request has been " & _
"approved: " & vbCrLf & _
"Approved For: " & vacApprovedName & vbCrLf & _
"Approved By: " & vacApproverName & vbCrLf & vbCrLf
& _
"Reason: " & toType & vbCrLf & _
"Dates: " & vacStart & " - " & vacEnd & vbCrLf & _
"Hours: " & vacHours & vbCrLf & _
"Comments: " & vacComments & vbCrLf & vbCrLf & _
"Drag the attached " & _
"Appointment to your Calendar. " & _
"Or, open it, then use File | Copy to Folder." &
vbCrLf & vbCrLf
'Send a Message to HR
Dim hr
Set hr = NewItem.Recipients.Add(hrAddress)
hr.Resolve
If hr.Resolved Then
hr.Type = olCC
End If
'Set the Approved Action
Item.UserProperties.Find("Approved") = "Approved"
Item.Save
Case "Disapprove"
'Disapprove Actions
Item.UserProperties.Find("Approved") = "Rejected"
Item.Save
Case Else
'Do Nothing
End Select
'Close the Form
Dim objInsp
Set objInsp = Item.GetInspector
objInsp.Close 2
End Function
Public Sub AddAppointment(ByVal strFolderPath,ByVal dStart,ByVal dEnd,ByVal
strSubject,ByVal NewItem)
Dim objAppt
Dim objVacFolder
Dim objAttachment
'Stop
Set objAppt = Application.CreateItem(olAppointmentItem)
With objAppt
.Start = dStart
.End = dEnd
.ReminderSet = False
.Subject = strSubject
.BusyStatus = olOutOfOffice
.Categories = Item.SenderName
.Body = "Hours: " & Item.UserProperties.Find("Time Off Hours") &
vbCrLf & _
"Comments: " & Item.ItemProperties.Item("Body")
End With
'Add the vacation as an Attachement
objAppt.Save
Set objAttachment = NewItem.Attachments.Add( _
objAppt, olByValue, , _
"Your Time Off")
'Stop
'Change a few properties on the appointment for the other calendars
objAppt.BusyStatus = olFree
objAppt.Subject = Item.SenderName & " - " & strSubject
'Add the vacation to the Approver's Calendar
Dim objMngrFolder
Dim objNS
Dim objItemCopy
Set objNS = Application.GetNamespace("MAPI")
Set objMngrFolder = objNS.GetDefaultFolder(olFolderCalendar)
Set objItemCopy = objAppt.Copy
If Not objMngrFolder Is Nothing Then
'objItemCopy.Move objMngrFolder
objItemCopy.Save
End If
'Stop
'Add the Appoinment to the Public Vacation Folder
'Set objVacFolder = GetFolder(strFolderPath)
Set objVacFolder = objNS.Folders.Item("Public
Folders").Folders.Item("All Public Folders").Folders.Item("vacations")
If Not objVacFolder Is Nothing Then
objAppt.Move objVacFolder
Else
objAppt.Delete
End If
Set objNS = Nothing
Set objItemCopy= Nothing
Set objMngrFolder = Nothing
Set objAppt = Nothing
Set objVacFolder = Nothing
Set objAttachment = Nothing
End Sub
Function GetMyManagerName()
Dim objNS
Dim objMe
Dim strName
Set objNS = Application.GetNamespace("MAPI")
Set objMe = objNS.CurrentUser
On Error Resume Next
strName = objMe.AddressEntry.Manager.Name
If Err = 0 Then
GetMyManagerName = strName
Else
GetMyManagerName = ""
End IF
Set objNS = Nothing
Set objMe = Nothing
End Function
Public Function GetFolder(strFolderPath)
Dim objNS
Dim colFolders
Dim objFolder
Dim arrFolders
Dim i
On Error Resume Next
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders = Split(strFolderPath, "\")
Set objNS = Application.GetNameSpace("MAPI")
Set objFolder = objNS.Folder.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then
Exit For
End If
Next
End If
Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objFolder = Nothing
End Function
Function GetFolderPath(objFolder)
Dim strPath
Dim objParent
On Error Resume Next
strPath = "\" & objFolder.Name
Do While Err = 0
Set objParent = objFolder.Parent
If Err = 0 Then
strPath = "\" & objParent.Name & strPath
Set objFolder = objParent
Else
Exit Do
End If
Loop
GetFolderPath = "\" & strPath
Set objParent = Nothing
End Function
Function GetCalFolderPath()
Dim objFolder
Dim objNS
Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.GetDefaultFolder(olFolderCalendar)
GetCalFolderPath = GetFolderPath(objFolder)
Set objFolder = Nothing
Set objNS = Nothing
End Function
