Public Function getOutlookFolderPath() As String
Dim olApp As Outlook.Application
Dim olSession As Outlook.NameSpace
Dim olStartFolder As Outlook.MAPIFolder
Set olApp = New Outlook.Application
Set olSession = olApp.GetNamespace("MAPI")
Set olStartFolder = olSession.PickFolder
If olStartFolder.DefaultItemType = 1 Then
getOutlookFolderPath = olStartFolder.FolderPath
getOutlookFolderPath = Mid(getOutlookFolderPath, 3)
Else
MsgBox "Can only import from a Calendar folder", vbInformation, "Pick a Calendar"
End If
End Function
Public Function GetFolder(strFolderPath As String) As MAPIFolder
' strFolderPath needs to be something like
' "Public Folders\All Public Folders\Company\Sales" or
' "Personal Folders\Inbox\My Folder"
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim I As Long
' On Error Resume Next
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objApp = Outlook.Application
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.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 objApp = Nothing
End Function