E
Eric32
We have a custom form we use for leave requests. The form has pretty basic
fields -- it allows the user to select the days and specific times and then
allows them to type a message. The "To" field is automatically populated
with their supervisor (which is pulled from Active Directory).
We're in the process of moving users from an older Windows 2003 Term Server
onto a new Windows 2003 Term Server. Both term servers have Office 2003 with
SP2 installed. On the new server the custom form opens fine, but it won't
populate the supervisor field. It works fine on the old term server and on
all of the desktops that are running Outlook.
Any ideas on why that one server won't work?
The form is published on the Exchange Server and we access it by going to
Tools/Choose Form and selecting it from the Organizational Forms Library.
Here's the code...it was written by a former employee:
-----------------------
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
fields -- it allows the user to select the days and specific times and then
allows them to type a message. The "To" field is automatically populated
with their supervisor (which is pulled from Active Directory).
We're in the process of moving users from an older Windows 2003 Term Server
onto a new Windows 2003 Term Server. Both term servers have Office 2003 with
SP2 installed. On the new server the custom form opens fine, but it won't
populate the supervisor field. It works fine on the old term server and on
all of the desktops that are running Outlook.
Any ideas on why that one server won't work?
The form is published on the Exchange Server and we access it by going to
Tools/Choose Form and selecting it from the Organizational Forms Library.
Here's the code...it was written by a former employee:
-----------------------
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