Run a macro on shared calendar in Outlook 2003
I have a macro that exports Outlook 2003 calender item details to Excel. I need to be able to run this against a calendar that I've been given "reveiwer" permissions to. So, this is another user's calendar that has been "shared" with me -- not a public calendar.
If I can get this person's calendar to appear in my Outlook folder list, I'll be able to do it -- but, haven't had any luck with that. If I click on the Calendar tab/shortcut in Outlook, then I see the list of calendar's to which I have permissions; but, I can't get any of them to appear in my Folder List.
Joe
If I can get this person's calendar to appear in my Outlook folder list, I'll be able to do it -- but, haven't had any luck with that. If I click on the Calendar tab/shortcut in Outlook, then I see the list of calendar's to which I have permissions; but, I can't get any of them to appear in my Folder List.
Joe
Last Comment
ASKER
Sure. The entire macro code is attached(Big shout-out to Helen Fedemma for providing).
To break it down, this macro asks for a desired start and end date, then a folder to run against (calendar). After that, it searches for specified AppointmentItem fields and exports to an Excel spreadsheet (Calendar.xls) that is stored in the OS default location for document templates.
I need to be able to run this against a co-worker's calendar that I have been given Reviewer permissions to. To reiterate, if this calendar could appear in my Outlook Folder List, then I'd be in good shape. From what I've read, by adding this user's mailbox to my profile, I thought I'd be able to see anything/only those things that I've been given any kind of permissions to. When I do this, the mailbox appears in my folder list -- but, when I click on it, I get an error that the folder cannot be expanded. I'm trying to get in touch with our Exchange admins to ask about this...
Joe
To break it down, this macro asks for a desired start and end date, then a folder to run against (calendar). After that, it searches for specified AppointmentItem fields and exports to an Excel spreadsheet (Calendar.xls) that is stored in the OS default location for document templates.
I need to be able to run this against a co-worker's calendar that I have been given Reviewer permissions to. To reiterate, if this calendar could appear in my Outlook Folder List, then I'd be in good shape. From what I've read, by adding this user's mailbox to my profile, I thought I'd be able to see anything/only those things that I've been given any kind of permissions to. When I do this, the mailbox appears in my folder list -- but, when I click on it, I get an error that the folder cannot be expanded. I'm trying to get in touch with our Exchange admins to ask about this...
Joe
Option Explicit
'Must declare as Object because folders may contain different
'types of items
Private itm As Object
Private strPrompt As String
Private strTitle As String
Sub SaveCalendarToExcel()
'Created by Helen Feddema 9-17-2004
'Last modified 20-Jul-2008
'Demonstrates pushing Calendar data to rows in an Excel worksheet
On Error GoTo ErrorHandler
Dim appExcel As Excel.Application
Dim appWord As Word.Application
Dim blnMultiDay As Boolean
Dim dteEnd As Date
Dim dteStart As Date
Dim fld As Outlook.MAPIFolder
Dim i As Integer
Dim intReturn As Integer
Dim itms As Outlook.Items
Dim j As Integer
Dim lngCount As Long
Dim nms As Outlook.NameSpace
Dim ritms As Outlook.Items
Dim rng As Excel.Range
Dim strDateRange As String
Dim strEndDate As String
Dim strSheet As String
Dim strSheetTitle As String
Dim strStartDate As String
Dim strTemplatePath As String
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
'Pick up Template path from the Word Options dialog
Set appWord = GetObject(, "Word.Application")
strTemplatePath = appWord.Options.DefaultFilePath(wdUserTemplatesPath) & "\"
Debug.Print "Templates folder: " & strTemplatePath
strSheet = "Calendar.xls"
strSheet = strTemplatePath & strSheet
Debug.Print "Excel workbook: " & strSheet
'Test for file in the Templates folder
If TestFileExists(strSheet) = False Then
strTitle = "Worksheet file not found"
strPrompt = strSheet & _
" not found; please copy Calendar.xls to this folder and try again"
MsgBox strPrompt, vbCritical + vbOKOnly, strTitle
GoTo ErrorHandlerExit
End If
'Put up input boxes for start date and end date, and
'create filter string
strPrompt = "Please enter a start date for filtering appointments"
strTitle = "Start Date"
strStartDate = Nz(InputBox(strPrompt, strTitle))
If strStartDate = "" Then
'Don't use a date range
strDateRange = ""
strSheetTitle = "Calendar Items from Excel"
GoTo SelectCalendarFolder
Else
If IsDate(strStartDate) = True Then
dteStart = CDate(strStartDate)
GoTo EndDate
Else
GoTo CreateWorksheet
End If
End If
EndDate:
strPrompt = "Please enter an end date for filtering appointments"
strTitle = "End Date"
strEndDate = Nz(InputBox(strPrompt, strTitle))
If IsDate(strEndDate) = True Then
dteEnd = CDate(strEndDate)
GoTo CreateFilter
Else
dteEnd = Date
End If
CreateFilter:
'Create date range string
strStartDate = dteStart & " 12:00 AM"
strEndDate = dteEnd & " 11:59 PM"
strDateRange = "[Start] >= """ & strStartDate & _
""" and [Start] <= """ & strEndDate & """"
Debug.Print strDateRange
strSheetTitle = "Calendar Items from Excel for " _
& Format(dteStart, "d-mmm-yyyy") & " to " _
& Format(dteEnd, "d-mmm-yyyy")
SelectCalendarFolder:
'Allow user to select Calendar folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
If fld Is Nothing Then
MsgBox "Please select a Calendar folder"
GoTo SelectCalendarFolder
End If
'Debug.Print "Default item type: " & fld.DefaultItemType
If fld.DefaultItemType <> olAppointmentItem Then
MsgBox "Please select a Calendar folder"
GoTo SelectCalendarFolder
End If
GetItems:
Set itms = fld.Items
itms.IncludeRecurrences = True
itms.Sort Property:="[Start]", descending:=False
'Debug.Print "Number of items: " & itms.Count
If strDateRange <> "" Then
Set ritms = itms.Restrict(strDateRange)
ritms.Sort Property:="[Start]", descending:=False
'Get an accurate count
lngCount = 0
For Each itm In ritms
Debug.Print "Appt. subject: " & itm.Subject _
& "; Start: " & itm.Start
lngCount = lngCount + 1
Next itm
Else
Set ritms = itms
End If
Debug.Print "Number of restricted items: " & lngCount
'Determine whether there are any multi-day events in the range
blnMultiDay = False
For Each itm In ritms
If itm.AllDayEvent = True Then
blnMultiDay = True
End If
Next itm
If blnMultiDay = True Then
'Ask whether to split all-day multi-day events
strTitle = "Question"
strPrompt = "Split all-day multi-day events into separate daily events" _
& vbCrLf & "so they can be exported correctly?"
intReturn = MsgBox(prompt:=strPrompt, _
Buttons:=vbQuestion + vbYesNo, _
Title:=strTitle)
If intReturn = True Then
Call SplitMultiDayEvents(itms)
'Reset ritms variable after splitting up multi-day events into
'separate days
Set ritms = ritms.Restrict(strDateRange)
ritms.Sort Property:="[Start]", descending:=False
End If
End If
CreateWorksheet:
Set appExcel = GetObject(, "Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Adjust i (row number) to be 1 less than the number of the first body row
i = 3
'Iterate through contact items in Calendar folder, and export a few fields
'from each item to a row in the Calendar worksheet
For Each itm In ritms
If itm.Class = olAppointment Then
'Process item only if it is an appointment item
i = i + 1
'j is the column number
j = 1
Set rng = wks.Cells(i, j)
If itm.Start <> "" Then rng.Value = itm.Start
j = j + 1
Set rng = wks.Cells(i, j)
If itm.End <> "" Then rng.Value = itm.End
j = j + 1
Set rng = wks.Cells(i, j)
If itm.CreationTime <> "" Then rng.Value = itm.CreationTime
j = j + 1
Set rng = wks.Cells(i, j)
If itm.Subject <> "" Then rng.Value = itm.Subject
j = j + 1
Set rng = wks.Cells(i, j)
If itm.Location <> "" Then rng.Value = itm.Location
j = j + 1
Set rng = wks.Cells(i, j)
If itm.Categories <> "" Then rng.Value = itm.Categories
j = j + 1
Set rng = wks.Cells(i, j)
If itm.IsRecurring <> "" Then rng.Value = itm.IsRecurring
j = j + 1
Set rng = wks.Cells(i, j)
On Error Resume Next
'The next line illustrates the syntax for referencing
'a custom Outlook field
If itm.UserProperties("CustomField") <> "" Then
rng.Value = itm.UserProperties("CustomField")
End If
j = j + 1
End If
i = i + 1
Next itm
Set rng = wks.Range("A1")
rng.Value = strSheetTitle
ErrorHandlerExit:
Exit Sub
ErrorHandler:
If Err.Number = 429 Then
'Application object is not set by GetObject; use CreateObject instead
If appWord Is Nothing Then
Set appWord = CreateObject("Word.Application")
Resume Next
ElseIf appExcel Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
Resume Next
End If
Else
MsgBox "Error No: " & Err.Number & "; Description: "
Resume ErrorHandlerExit
End If
End Sub
Public Function TestFileExists(strFile As String) As Boolean
'Created by Helen Feddema 9-1-2004
'Last modified 9-1-2004
'Tests for existing of a file, using the FileSystemObject
Dim fso As New Scripting.FileSystemObject
Dim fil As Scripting.File
On Error Resume Next
Set fil = fso.GetFile(strFile)
If fil Is Nothing Then
TestFileExists = False
Else
TestFileExists = True
End If
End Function
Public Sub SplitMultiDayEvents(itmsSet As Outlook.Items)
'Created by Helen Feddema 7-Jun-2007
'Last modified 20-Jul-2008
On Error GoTo ErrorHandler
Dim dteNewEnd As Date
Dim itmCopy As Outlook.AppointmentItem
Dim lngDayCount As Long
Dim n As Integer
Dim strApptStart As String
Dim strApptEnd As String
Dim strApptRange As String
Dim strApptSubject As String
Dim strApptLocation As String
Dim strApptNotes As String
Dim strNewDate As String
For Each itm In itmsSet
strApptStart = Format(itm.Start, "h:mma/p")
strApptEnd = Format(itm.End, "h:mma/p")
strApptRange = strApptStart & " - " & strApptEnd & ":"
strApptSubject = itm.Subject
strApptLocation = itm.Location
strApptNotes = itm.Body
If itm.AllDayEvent = True Then
Debug.Print "All-day appt. range: " & itm.Start & " to " & itm.End
'Check for multi-day all-day events, and make a separate all-day event
'for each day in the date range if found
lngDayCount = DateDiff("d", itm.Start, itm.End)
If lngDayCount > 1 Then
'This is a multi-day event; change original event to a single-day event
dteNewEnd = DateAdd("d", 1, itm.Start)
strNewDate = dteNewEnd & " 12:00 AM"
itm.End = strNewDate
itm.Close (olSave)
'Make copies of this event for the other days in the range
For n = 1 To lngDayCount - 1
Set itmCopy = itm.Copy
itmCopy.Subject = strApptSubject
itmCopy.Location = strApptLocation
itmCopy.AllDayEvent = True
itmCopy.Body = strApptNotes
itmCopy.Start = strNewDate
dteNewEnd = DateAdd("d", 1, dteNewEnd)
strNewDate = dteNewEnd & " 12:00 AM"
itmCopy.End = strNewDate
'itmCopy.Display
itmCopy.Close (olSave)
Next n
End If
End If
Next itm
strTitle = "Done"
strPrompt = "Multi-day events split"
MsgBox prompt:=strPrompt, _
Buttons:=vbInformation + vbOKOnly, _
Title:=strTitle
ErrorHandlerExit:
Exit Sub
ErrorHandler:
MsgBox "Error No: " & Err.Number & "; Description: " & _
Err.Description
Resume ErrorHandlerExit
End Sub
The error is probably the result of insufficient permissions at a higher level. In other words, to access the calendar I believe you have to have permissions at the mailbox. In non-Outlook terms, giving you a key to a door inside a building is useless if you can't get into the building to use the key. That aside, we can try modifying the code and see if you can get to the folder without it appearing in your folder list. Do you want to try that? It involves adding some code (I'll provide) to what you have now and changing one line of the code you posted.
ASKER
BlueDevilFan,
Maybe hold off until I can get in touch with the Exchange admins to see if they can help.
Joe
Maybe hold off until I can get in touch with the Exchange admins to see if they can help.
Joe
ASKER
OK - so, my Exchange guy took a look and said he'd see what he could do -- but, I don't get the idea that it's going to be a very hi priority for him.
BlueDevilFan, If you have time, I'd like to try your suggestion.
BlueDevilFan, If you have time, I'd like to try your suggestion.
ASKER CERTIFIED SOLUTION
THIS SOLUTION IS ONLY AVAILABLE TO MEMBERS.
View this solution by signing up for a free trial.
Members can start a 7-Day free trial and enjoy unlimited access to the platform.
ASKER
Does it matter where I insert your code? I tried putting it in a logical-to-me place (being an absolute VBA rookie), and got an error.
The best place for it is immediately below the code you already have. Placement may not be the problem though. What was the error?
ASKER
At first, I inserted it in the midst of the existing code. So, I got (expectedly, as I know understand) and error about "end sub" expected.
Now, I've placed it at the end and the code runs -- but, when it gets to the point to select a calendar folder, I get an alert box that instructs me to "please select a calender folder", with an OK button. But, it won't allow me to select anything and cannot close the alert box. I have to go to task manager and kill Outlook.
Now, I've placed it at the end and the code runs -- but, when it gets to the point to select a calendar folder, I get an alert box that instructs me to "please select a calender folder", with an OK button. But, it won't allow me to select anything and cannot close the alert box. I have to go to task manager and kill Outlook.
Did you replace line #107 as I explained above?
ASKER
Yep - with a couple of different users' mailboxes. Same thing -- alert box asking to specify a calendar folder but has Outlook locked up and I can't do anything other than kill the app.
attached is the code as it currently stands, and a screenshot of the error box. You'll see that I commented out the orig code from line 107.
attached is the code as it currently stands, and a screenshot of the error box. You'll see that I commented out the orig code from line 107.
Option Explicit
'Must declare as Object because folders may contain different
'types of items
Private itm As Object
Private strPrompt As String
Private strTitle As String
Sub SaveCalendarToExcel()
'Created by Helen Feddema 9-17-2004
'Last modified 20-Jul-2008
'Demonstrates pushing Calendar data to rows in an Excel worksheet
On Error GoTo ErrorHandler
Dim appExcel As Excel.Application
Dim appWord As Word.Application
Dim blnMultiDay As Boolean
Dim dteEnd As Date
Dim dteStart As Date
Dim fld As Outlook.MAPIFolder
Dim i As Integer
Dim intReturn As Integer
Dim itms As Outlook.Items
Dim j As Integer
Dim lngCount As Long
Dim nms As Outlook.NameSpace
Dim ritms As Outlook.Items
Dim rng As Excel.Range
Dim strDateRange As String
Dim strEndDate As String
Dim strSheet As String
Dim strSheetTitle As String
Dim strStartDate As String
Dim strTemplatePath As String
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
'Pick up Template path from the Word Options dialog
Set appWord = GetObject(, "Word.Application")
strTemplatePath = appWord.Options.DefaultFilePath(wdUserTemplatesPath) & "\"
Debug.Print "Templates folder: " & strTemplatePath
strSheet = "Calendar.xls"
strSheet = strTemplatePath & strSheet
Debug.Print "Excel workbook: " & strSheet
'Test for file in the Templates folder
If TestFileExists(strSheet) = False Then
strTitle = "Worksheet file not found"
strPrompt = strSheet & _
" not found; please copy Calendar.xls to this folder and try again"
MsgBox strPrompt, vbCritical + vbOKOnly, strTitle
GoTo ErrorHandlerExit
End If
'Put up input boxes for start date and end date, and
'create filter string
strPrompt = "Please enter a start date for filtering appointments"
strTitle = "Start Date"
strStartDate = Nz(InputBox(strPrompt, strTitle))
If strStartDate = "" Then
'Don't use a date range
strDateRange = ""
strSheetTitle = "Calendar Items from Excel"
GoTo SelectCalendarFolder
Else
If IsDate(strStartDate) = True Then
dteStart = CDate(strStartDate)
GoTo EndDate
Else
GoTo CreateWorksheet
End If
End If
EndDate:
strPrompt = "Please enter an end date for filtering appointments"
strTitle = "End Date"
strEndDate = Nz(InputBox(strPrompt, strTitle))
If IsDate(strEndDate) = True Then
dteEnd = CDate(strEndDate)
GoTo CreateFilter
Else
dteEnd = Date
End If
CreateFilter:
'Create date range string
strStartDate = dteStart & " 12:00 AM"
strEndDate = dteEnd & " 11:59 PM"
strDateRange = "[Start] >= """ & strStartDate & _
""" and [Start] <= """ & strEndDate & """"
Debug.Print strDateRange
strSheetTitle = "Calendar Items from Excel for " _
& Format(dteStart, "d-mmm-yyyy") & " to " _
& Format(dteEnd, "d-mmm-yyyy")
SelectCalendarFolder:
'Allow user to select Calendar folder
Set nms = Application.GetNamespace("MAPI")
'Set fld = nms.PickFolder
Set fld = OpenOutlookFolder("Mailbox - John Kovarik/Calendar")
If fld Is Nothing Then
MsgBox "Please select a Calendar folder"
GoTo SelectCalendarFolder
End If
'Debug.Print "Default item type: " & fld.DefaultItemType
If fld.DefaultItemType <> olAppointmentItem Then
MsgBox "Please select a Calendar folder"
GoTo SelectCalendarFolder
End If
GetItems:
Set itms = fld.Items
itms.IncludeRecurrences = True
itms.Sort Property:="[Start]", descending:=False
'Debug.Print "Number of items: " & itms.Count
If strDateRange <> "" Then
Set ritms = itms.Restrict(strDateRange)
ritms.Sort Property:="[Start]", descending:=False
'Get an accurate count
lngCount = 0
For Each itm In ritms
Debug.Print "Appt. subject: " & itm.Subject _
& "; Start: " & itm.Start
lngCount = lngCount + 1
Next itm
Else
Set ritms = itms
End If
Debug.Print "Number of restricted items: " & lngCount
'Determine whether there are any multi-day events in the range
blnMultiDay = False
For Each itm In ritms
If itm.AllDayEvent = True Then
blnMultiDay = True
End If
Next itm
If blnMultiDay = True Then
'Ask whether to split all-day multi-day events
strTitle = "Question"
strPrompt = "Split all-day multi-day events into separate daily events" _
& vbCrLf & "so they can be exported correctly?"
intReturn = MsgBox(prompt:=strPrompt, _
Buttons:=vbQuestion + vbYesNo, _
Title:=strTitle)
If intReturn = True Then
Call SplitMultiDayEvents(itms)
'Reset ritms variable after splitting up multi-day events into
'separate days
Set ritms = ritms.Restrict(strDateRange)
ritms.Sort Property:="[Start]", descending:=False
End If
End If
CreateWorksheet:
Set appExcel = GetObject(, "Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Adjust i (row number) to be 1 less than the number of the first body row
i = 3
'Iterate through contact items in Calendar folder, and export a few fields
'from each item to a row in the Calendar worksheet
For Each itm In ritms
If itm.Class = olAppointment Then
'Process item only if it is an appointment item
i = i + 1
'j is the column number
j = 1
Set rng = wks.Cells(i, j)
If itm.RequiredAttendees <> "" Then rng.Value = itm.RequiredAttendees
j = j + 10
Set rng = wks.Cells(i, j)
If itm.Start <> "" Then rng.Value = itm.Start
j = j + 1
Set rng = wks.Cells(i, j)
If itm.Location <> "" Then rng.Value = itm.Location
j = j + 2
Set rng = wks.Cells(i, j)
If itm.Organizer <> "" Then rng.Value = itm.Organizer
j = j + 1
Set rng = wks.Cells(i, j)
If itm.Duration <> "" Then rng.Value = itm.Duration
j = j + 1
Set rng = wks.Cells(i, j)
If itm.Subject <> "" Then rng.Value = itm.Subject
j = j + 1
Set rng = wks.Cells(i, j)
If itm.Body <> "" Then rng.Value = itm.Body
j = j + 1
Set rng = wks.Cells(i, j)
On Error Resume Next
'The next line illustrates the syntax for referencing
'a custom Outlook field
If itm.UserProperties("CustomField") <> "" Then
rng.Value = itm.UserProperties("CustomField")
End If
j = j + 1
End If
'i = i + 1
Next itm
Set rng = wks.Range("A1")
rng.Value = strSheetTitle
ErrorHandlerExit:
Exit Sub
ErrorHandler:
If Err.Number = 429 Then
'Application object is not set by GetObject; use CreateObject instead
If appWord Is Nothing Then
Set appWord = CreateObject("Word.Application")
Resume Next
ElseIf appExcel Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
Resume Next
End If
Else
MsgBox "Error No: " & Err.Number & "; Description: "
Resume ErrorHandlerExit
End If
End Sub
Public Function TestFileExists(strFile As String) As Boolean
'Created by Helen Feddema 9-1-2004
'Last modified 9-1-2004
'Tests for existing of a file, using the FileSystemObject
Dim fso As New Scripting.FileSystemObject
Dim fil As Scripting.File
On Error Resume Next
Set fil = fso.GetFile(strFile)
If fil Is Nothing Then
TestFileExists = False
Else
TestFileExists = True
End If
End Function
Public Sub SplitMultiDayEvents(itmsSet As Outlook.Items)
'Created by Helen Feddema 7-Jun-2007
'Last modified 20-Jul-2008
On Error GoTo ErrorHandler
Dim dteNewEnd As Date
Dim itmCopy As Outlook.AppointmentItem
Dim lngDayCount As Long
Dim n As Integer
Dim strApptStart As String
Dim strApptEnd As String
Dim strApptRange As String
Dim strApptSubject As String
Dim strApptLocation As String
Dim strApptNotes As String
Dim strNewDate As String
For Each itm In itmsSet
strApptStart = Format(itm.Start, "h:mma/p")
strApptEnd = Format(itm.End, "h:mma/p")
strApptRange = strApptStart & " - " & strApptEnd & ":"
strApptSubject = itm.Subject
strApptLocation = itm.Location
strApptNotes = itm.Body
If itm.AllDayEvent = True Then
Debug.Print "All-day appt. range: " & itm.Start & " to " & itm.End
'Check for multi-day all-day events, and make a separate all-day event
'for each day in the date range if found
lngDayCount = DateDiff("d", itm.Start, itm.End)
If lngDayCount > 1 Then
'This is a multi-day event; change original event to a single-day event
dteNewEnd = DateAdd("d", 1, itm.Start)
strNewDate = dteNewEnd & " 12:00 AM"
itm.End = strNewDate
itm.Close (olSave)
'Make copies of this event for the other days in the range
For n = 1 To lngDayCount - 1
Set itmCopy = itm.Copy
itmCopy.Subject = strApptSubject
itmCopy.Location = strApptLocation
itmCopy.AllDayEvent = True
itmCopy.Body = strApptNotes
itmCopy.Start = strNewDate
dteNewEnd = DateAdd("d", 1, dteNewEnd)
strNewDate = dteNewEnd & " 12:00 AM"
itmCopy.End = strNewDate
'itmCopy.Display
itmCopy.Close (olSave)
Next n
End If
End If
Next itm
strTitle = "Done"
strPrompt = "Multi-day events split"
MsgBox prompt:=strPrompt, _
Buttons:=vbInformation + vbOKOnly, _
Title:=strTitle
ErrorHandlerExit:
Exit Sub
ErrorHandler:
MsgBox "Error No: " & Err.Number & "; Description: " & _
Err.Description
Resume ErrorHandlerExit
End Sub
Function IsNothing(obj)
If TypeName(obj) = "Nothing" Then
IsNothing = True
Else
IsNothing = False
End If
End Function
Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
Dim arrFolders As Variant, _
varFolder As Variant, _
olkFolder As Outlook.MAPIFolder
On Error GoTo ehOpenOutlookFolder
If strFolderPath = "" Then
Set OpenOutlookFolder = Nothing
Else
If Left(strFolderPath, 1) = "\" Then
strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
End If
arrFolders = Split(strFolderPath, "\")
For Each varFolder In arrFolders
If IsNothing(olkFolder) Then
Set olkFolder = Session.Folders(varFolder)
Else
Set olkFolder = olkFolder.Folders(varFolder)
End If
Next
Set OpenOutlookFolder = olkFolder
End If
On Error GoTo 0
Exit Function
ehOpenOutlookFolder:
Set OpenOutlookFolder = Nothing
On Error GoTo 0
End Function
Then either the path to the folder is wrong or the path is correct and the code can't open the folder for the same reason you can't get to it in the Outlook interface.
ASKER
I'm thinking it's the latter. But, confoundingly, I put my own mailbox/calendar in there and the same thing happens. That alert box comes up, locks Outlook and I can't get the alert box to go away.
ASKER
So, I'm a complete rookie at VBA. Do you think that I'm getting the alert box because it can't find/open the mailbox specified in the code?
Yes, that's exactly what I think. I expect it's a permissions issue just like in the interface.
ASKER
OK - I'm going to accept your solution even though I haven't been able to see if it works. If we get the permissions issue sorted out and I still have trouble, I'll post another question.
Thanks for your help.
Thanks for your help.
You're welcome.
Outlook
Microsoft Outlook is a personal information manager from Microsoft, available as a part of the Microsoft Office suite. Although often used mainly as an email application, it also includes a calendar, task manager, contact manager, note-taker, journal, and web browser.
105K
Questions
--
Followers
--
Top Experts
Get a personalized solution from industry experts
TRUSTED BY
The calendar doesn't have to appear in the folder list for code to work on it. Can you share the code? If so, then I can probably modify it or add code so you can read the folder.