Outlook Vacation form modifications...Please help.

[jguderian]

Hello All!

I have been using a modified vacation form from Sue Mosher for quite some time now. However I have a couple of questions/requests that I hope can be answered.

1. I would like the two field that are available for date entry to validate that it is for a future date. If it is a past date, pop-up a box saying something to that effect.
2. I would also like to build in the ability to have a box that displays the # of used vacation days for the individual currently requesting vacation, based off of the Public Folder entries this form creates. I would need this to exclude weekends. The syntax that is created in the subject line is "User Display Name - Vacation"

I really appreciate the help! Below is my current code for the form.

Option Explicit

Dim mstrVacFolder ' public Vacations folder full path

Const olOutOfOffice = 3
Const olAppointmentItem = 1
Const olByValue = 1
Const olFolderCalendar = 9

Sub InitOpts()
' set user options

'public Vacations folder name and path
mstrVacFolder = "Public Folders/All Public Folders/Vacations"
End Sub

Function Item_Open()
Dim objPage
Dim objCtrl
Dim objRecip
Dim strManager
Dim strFolderPath

InitOpts

Set objPage = Item.GetInspector.ModifiedFormPages("Vacations")
Set objCtrl = objPage.Controls("OVCtl1")
If Item.Size = 0 Then
' show user Calendar in view control
With objCtrl
.Folder = GetCalFolder()
.View = "Events"
.Restriction = "[Subject] = ""Vacation"""
End With

' 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("txtVacStart")
objCtrl.SetFocus
End IF
End If
Else
With objCtrl
' show public Vacations folder in view control
.Folder = "\" & Replace(mstrVacFolder,"/","\")
.View = "Day/Week/Month" ' name of custom view
End With
End If

Set objPage = Nothing
Set objCtrl = Nothing
Set objRecip = Nothing
End Function

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

Select Case Action.Name
Case "Approve"
' create appointment for user to save to calendar
dteStart = _
Item.UserProperties("VacationStart")
dteEnd = _
Item.UserProperties("VacationEnd")
Set objAppt = _
Application.CreateItem(olAppointmentItem)
With objAppt
.Start = dteStart
.End = dteEnd
.ReminderSet = False
.Subject = "Vacation"
.AllDayEvent = True
.BusyStatus = olOutOfOffice
End With
objAppt.Save
Set objAttachment = NewItem.Attachments.Add( _
objAppt, olByValue, , _
"Your Vacation")
NewItem.CC = "someaddress@domain.com"
NewItem.Body = "Your vacation has been " & _
"approved. Drag the attached " & _
"Appointment to your Calendar. " & _
"Or, open it, then use File | Copy to Folder." & vbCrLf & vbCrLf
Set objInsp = Item.GetInspector
objInsp.Close 0 'olSave

' move appointment to public folder
objAppt.Subject = Item.SenderName & " - Vacation"
Set objFolder = GetMAPIFolder(mstrVacFolder)
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

Function GetFolderPath(objFolder)
' from Randy Byrne, Building Applications with Outlook 2000
On Error Resume Next
Dim strFolderPath
Dim objChild
Dim objParent

strFolderPath = "\" & objFolder.Name
Set objChild = objFolder
Do Until Err <> 0
Set objParent = objChild.Parent
If Err <> 0 Then
Exit Do
End If
strFolderPath = "\" & objParent.Name & strFolderPath
Set objChild = objParent
Loop
GetFolderPath = strFolderPath

Set objChild = Nothing
Set objParent = Nothing
End Function

Function GetCalFolder()
Dim objFolder
Dim objNS

Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.GetDefaultFolder(olFolderCalendar)
GetCalFolder = GetFolderPath(objFolder)

Set objFolder = Nothing
Set objNS = Nothing
End Function

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