Welcome to FreeSoftwareServers Confluence Wiki

Sub Testing()
  Set olFoldersDic = CreateObject("scripting.dictionary")
  Set olFoldersDic = GetolFoldersDic()
  For Each k In olFoldersDic.Keys
   Debug.Print "Folder = " & k
   Debug.Print "Path = " & olFoldersDic(k)
  Next
End Sub
Private IgnoreFoldersArr() As String
Public olFoldersDic As Object  Public Function GetolFoldersDic() As Object

 Set GetolFoldersDic = CreateObject("scripting.dictionary")
 Dim olApp As Outlook.Application
 Set olApp = CreateObject("outlook.application")
    
 Dim olSession As Outlook.NameSpace
 Set olSession = olApp.GetNamespace("MAPI")
 
 Dim olStartFolder As Outlook.MAPIFolder
 Set olStartFolder = olSession.GetDefaultFolder(olFolderInbox).Parent
    
 IgnoreFoldersArr = Split("Social Activity Notifications,ExternalContacts,Conversation Action Settings,PersonMetadata,Journal,Quick Step Settings,RSS Subscriptions,Archive,Notes,Sync Issues,Yammer Root,Files,Tasks,Contacts,Calendar,Conversation History,Drafts,Junk Email,Sent Items,Outbox,Inbox,Deleted Items,Team Chat,Birthdays,United States holidays,Recipient Cache,Skype for Business Contacts,PeopleCentricConversation Buddies,Organizational Contacts,GAL Contacts,Companies,Feeds,Inbound,Outbound,Local Failures,Server Failures,Conflicts", ",")
 
 Dim olNewFolder As Outlook.MAPIFolder, i As Long, olFolderStr As String, olFolderPath As String, TempDic As Object
 Set TempDic = CreateObject("scripting.dictionary")
 For Each olNewFolder In olStartFolder.Folders
  If IsStrInArr(IgnoreFoldersArr, olNewFolder.Name) = False Then
   If olNewFolder.Folders.Count > 0 Then
    For i = olNewFolder.Folders.Count To 1 Step -1
     olFolderStr = Trim(olNewFolder.Folders(i))
     olFolderPath = olNewFolder.Folders(i).FolderPath
     If Not TempDic.Exists(olFolderStr) Then
        TempDic.Add Key:=olFolderStr, Item:=olFolderPath
     End If
    Next
   Else
     olFolderStr = Trim(olNewFolder.Name)
     olFolderPath = olNewFolder.FolderPath
     If Not TempDic.Exists(olFolderStr) Then
        TempDic.Add Key:=olFolderStr, Item:=olFolderPath
     End If
   End If
  End If
 Next
 TempDic.Add Key:="DOWNLOADATTACHMENTS", Item:="DOWNLOADATTACHMENTS"
 TempDic.Add Key:="JUNK", Item:="JUNK"
 Set GetolFoldersDic = TempDic
End Function

OLD:

Public IgnoreFoldersArr() As String

Public Sub GetFolderNames()
 Dim olApp As Outlook.Application
 Set olApp = CreateObject("outlook.application") 'New Outlook.Application
    
 Dim olSession As Outlook.NameSpace
 Set olSession = olApp.GetNamespace("MAPI")
 
 Dim olStartFolder As Outlook.MAPIFolder
 Set olStartFolder = olSession.GetDefaultFolder(olFolderInbox).Parent
    
 IgnoreFoldersArr = Split("Social Activity Notifications,ExternalContacts,Conversation Action Settings,PersonMetadata,Journal,Quick Step Settings,RSS Subscriptions,Archive,Notes,Sync Issues,Yammer Root,Files,Tasks,Contacts,Calendar,Conversation History,Drafts,Junk Email,Sent Items,Outbox,Inbox,Deleted Items,Team Chat,Birthdays,United States holidays,Recipient Cache,Skype for Business Contacts,PeopleCentricConversation Buddies,Organizational Contacts,GAL Contacts,Companies,Feeds,Inbound,Outbound,Local Failures,Server Failures,Conflicts", ",")
 Dim olFoldersDic As Object
 Set olFoldersDic = CreateObject("scripting.dictionary")
 Set olFoldersDic = GetOLFoldersDic(olStartFolder)

 Dim k
 For Each k In olFoldersDic.Keys
  Debug.Print k
 Next
 
End Sub

Public Function GetOLFoldersDic(CurrentFolder As Outlook.MAPIFolder) As Object
 Set GetOLFoldersDic = CreateObject("scripting.dictionary")
 Dim tmp As String
 Set TempDic = CreateObject("scripting.dictionary")
 Dim olNewFolder As Outlook.MAPIFolder, i As Long
 For Each olNewFolder In CurrentFolder.Folders
  If IsStrInArr(IgnoreFoldersArr, olNewFolder.Name) = False Then
    For i = olNewFolder.Folders.Count To 1 Step -1
     tmp = Trim(olNewFolder.Folders(i))
     If Not TempDic.Exists(tmp) Then
      If Len(tmp) > 0 Then TempDic(tmp) = TempDic(tmp) + 1
     End If
    Next
  End If
 Next
 Set GetOLFoldersDic = TempDic
End Function

Public Function IsStrInArr(Arr As Variant, StrToCheck As String) As Boolean
 IsStrInArr = UBound(Filter(Arr, StrToCheck)) > -1
End Function
  • No labels