Vacation Calendar

B

bigbrorpi

Hi -

I was following an old thread about Sue Mosher's vacation calendar
example. I've published her Vacation Request form in my Org. Forms
Library and when I try to open it, I get a permission denied error as
soon as it hits:
GetCalFolder=GetfolderPath(objFolder)
My code is below - any help would be appreciated.

Thanks


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 = "Vacation 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

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.Body = "Your vacation has been " & _
"approved. Open the attached " & _
"Appointment and save it to " & _
"your Calendar." & vbCrLf & vbCrLf

' 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
 
S

Sue Mosher [MVP-Outlook]

Since GetFolder() is a function, it might be helpful if you stepped through the code and through that function to determine where the error is occurring.

--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers



Hi -

I was following an old thread about Sue Mosher's vacation calendar
example. I've published her Vacation Request form in my Org. Forms
Library and when I try to open it, I get a permission denied error as
soon as it hits:
GetCalFolder=GetfolderPath(objFolder)
My code is below - any help would be appreciated.

Thanks


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 = "Vacation 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

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.Body = "Your vacation has been " & _
"approved. Open the attached " & _
"Appointment and save it to " & _
"your Calendar." & vbCrLf & vbCrLf

' 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
Click to expand...
 
B

bigbrorpi

Sue -

Thanks for your reply. It's strange - if I step through in the VB
debugger, it doesn't really do anything but doesn't throw errors. If I
just run it in Outlook I get permission denied. Is there another way
that I should be debugging this?

Thanks
B
 
S

Sue Mosher [MVP-Outlook]

Sorry, but what is the problem again? The newsgroup interface you are using apparently does not quote earlier messages in the thread, making your latest message so short on detail that you risk not getting the answer you're looking for.
 
B

bigbrorpi

Hi -

I was following an old thread about Sue Mosher's vacation calendar
example. I've published her Vacation Request form in my Org. Forms
Library and when I try to open it, I get a permission denied error as
soon as it hits:
GetCalFolder=GetfolderPath(objFolder)
My code is below - any help would be appreciated.

Thanks

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 = "Vacation 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

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.Body = "Your vacation has been " & _
"approved. Open the attached " & _
"Appointment and save it to " & _
"your Calendar." & vbCrLf & vbCrLf

' 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
 
S

Sue Mosher [MVP-Outlook]

Outlook version? You might want to add a MsgBox statement to the GetFolderPath() function to check the value of the path string while it's in the loop.

--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers



Hi -

I was following an old thread about Sue Mosher's vacation calendar
example. I've published her Vacation Request form in my Org. Forms
Library and when I try to open it, I get a permission denied error as
soon as it hits:
GetCalFolder=GetfolderPath(objFolder)
My code is below - any help would be appreciated.

Thanks

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 = "Vacation 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

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.Body = "Your vacation has been " & _
"approved. Open the attached " & _
"Appointment and save it to " & _
"your Calendar." & vbCrLf & vbCrLf

' 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
Click to expand...
 
B

bigbrorpi

Sue

It's Outlook 2000.
I tried the message box, and I do get the correct path.

Thanks
B
 

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

Custom Form not working on new term server 3
Vacation Request Form 1
objTargetFolder can't move item 2
how can i know the complete path to an outlook folder ? 8
Post to additional public calendar 3
Problem writing Outlook data to Access table 0
Senders email address in saved attachment 1
For Each loop not getting all Email Items 3

Top