I'm trying to create a recursive function which adds each folder (and subfolders) to a collection of custom objects. My code is working for around 75% of the folders / subfolders but seemingly random ones are being missed from the collection.
Any ideas?
FolderObj is a custom class, the collection I'm adding to is called ToPathList
Option Explicit
Sub RecurseFolderList(Foldername As String)
On Error Resume Next
Dim FSO, NextFolder
Dim OriginalRange As Range
Dim tempFolderObj As FolderObj
Dim i As Integer
i = 1
Set FSO = CreateObject("Scripting.FileSystemObject")
If Err.Number > 0 Then
Exit Sub
End If
If FSO.FolderExists(Foldername) Then
Set NextFolder = FSO.GetFolder(Foldername)
Set FolderArray = NextFolder.subfolders
For Each NextFolder In FolderArray
Set tempFolderObj = New FolderObj
'assign variables to temporary object
With tempFolderObj
.ID = i
.Filename = NextFolder.Name
.path = NextFolder.path
.first3ints = first3Non0Ints(NextFolder.Name)
End With
'add temporary object to colelction
Call ToPathList.Add(tempFolderObj, CStr(i))
i = i + 1
RecurseFolderList (NextFolder)
Next
' Set NextFolder = Nothing
' Set FolderArray = Nothing
End If
Set FSO = Nothing
End Sub
My key (i) was declared inside the function and therefore was being reset to '1' every time the function was recursed.
This resulted in non-unique keys and therefore some items were not being added to the collection.
Thanks to everyone for their help.
Related
Cannot figure out how to implement the following use case.
I pass a folder and criterias (seperated by a ";") to a function and retrieve a file if criterias were matched.
This is working quite well, but I have an exception:
If the criteria pattern in the first position is "ABC", there are multiple files which could match the search pattern.
My goal is to prioritize the finding in a sense that a file containing "RD_" should have a higher prioritization than a file which contains the string "SD_".
Hint:
If a file has the string "RD_" inside and matches also the other criterias, then the function can stop.
If a file has the string "SD_" inside and matches also the other criterias, then the function should not stop and still loop all files within the folder and try to find a file matching all criterias AND "RD_".
Hope you can help me further.
Sub getTargetFile()
Debug.Print getInputFilePath("D:\", "ABC;11111")
End Sub
Function getInputFilePath(inputDirectoryToScanForFile, filenameCriteria) As String
Dim vSplitCriteria: vSplitCriteria = Split(filenameCriteria, ";") ' Split the criteria into pieces and put them into an array
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer
Dim sFoundFile As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(inputDirectoryToScanForFile)
Dim blnCorrectFiles As Boolean
For Each oFile In oFolder.Files ' Loop through each file in folder
blnCorrectFiles = True ' assume the current file is correct
'Debug.Print oFile.Name
For i = LBound(vSplitCriteria) To UBound(vSplitCriteria) ' Loop through all file name criteria
If Not InStr(1, UCase(oFile.Name), UCase(vSplitCriteria(i))) > 0 Then ' check whether criteia matched
blnCorrectFiles = False
End If
If blnCorrectFiles = False Then Exit For
Next i
If blnCorrectFiles = True Then ' if all criteria are matched, otherwise it was set to false inbetween the above loop
sFoundFile = oFile.Name
Exit For
End If
Next oFile
If blnCorrectFiles = True Then
getInputFilePath = inputDirectoryToScanForFile & sFoundFile
Else
getInputFilePath = ""
End If
End Function
It sounds like you want to check for RD_ first and then if nothing is found, check for SD_. Which sounds like you just need to run the function twice. Trying to mix and match inside the function would be difficult to generalize and only make things messy.
Sub Prioritize()
Dim Directory As String
Directory = "D:\"
Dim Criteria As String
Criteria = "ABC;11111"
Dim fPath As String
fPath = getInputFilePath(Directory, "RD_;" & Criteria)
If fPath = "" Then fPath = getInputFilePath(Directory, "SD_;" & Criteria)
End Sub
Is there a method in VBA to achieve the same effect of right-clicking on a folder in the folder pane and selecting 'Sort Subfolders A to Z'?
As a comparison, the code below from Microsoft.com sorts Items in a folder; however, it does not appear that the .Sort method used in this code is available for the Folders object like it is for the Items object.
Sub SortByDueDate()
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myItem As Outlook.TaskItem
Dim myItems As Outlook.Items
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderTasks)
Set myItems = myFolder.Items
myItems.Sort "[DueDate]", False
For Each myItem In myItems
MsgBox myItem.Subject & "-- " & myItem.DueDate
Next myItem
End Sub
Additionally, it does not appear that there are any methods available for moving folders in the tree.
Is more extensive code required to replicate the native 'Sort Subfolders A to Z' action with VBA?
Can this be achieved with PropertyAssessor and, if so, what is the proper syntax for setting the PR_SORT_POSITION property? For example, the code below results in an error, as commented in the code.
Sub Example()
Dim myProp As String
Dim myValue As Variant
Dim oFolder As Folder
Set oFolder = Application.Session.GetDefaultFolder(olFolderInbox)
myProp = "http://schemas.microsoft.com/mapi/proptag/0x30200102"
myValue = "FD7F"
oFolder.PropertyAssessor.SetProperty myProp, myValue 'Run-time error '438': Object doesn't support this property or method
End Sub
The Outlook object model doesn't provide any property or method to sort folders. You may find the NavigationPane object helpful. See Customizing the Navigation Pane for more information.
You can sort the folders in the Outlook UI by explicitly setting the PR_SORT_POSITION property on each subfolder - see Get folder list ordered as displayed
I posted my code here because this was high in Google results and all other threads were closed
https://answers.microsoft.com/en-us/outlook_com/forum/all/sorting-outlook-subfolders-z-a/9aef727c-510c-49e0-869d-4234373b71d7
https://answers.microsoft.com/en-us/outlook_com/forum/all/sort-order-of-subfolders/a3b55181-4f5a-43c1-82b3-94eb68a8407b
I've made custom VBA code to sort subfolders Z-A - it will load the folder order [unfortunately you still need to order it A-Z within outlook] and then reverse it so it is Z-A
I needed to quickly adjust a tonne of folders and couldn't find any code anywhere, so I quickly made the below to help patch the issue.
I didn't have the time to write lots of detail about how it works.
Known issues with the code:
It doesn't always sort the first folder. No idea why.
It doesn't seem to like it when you're looking at the list of subfolders - minimise it then run the code
This code is used to reverse the sorting of subfolders under Inbox, you'll need to adjust as required.
Sub sortZA()
Dim email_name: email_name = "email#emails.com" 'write the name of the mailbox as it appears in outlook
Dim objMainFolder As Outlook.Folder
Dim Folders As Outlook.Folders
Dim Folderx As Outlook.Folder
Dim sort_order, sort_order_b, arr
Set arr = CreateObject("System.Collections.ArrayList")
Set arr_sorted = CreateObject("System.Collections.ArrayList")
dim found_folder: found_folder=0
Set Folders = Application.ActiveExplorer.Session.Folders
For Each Folderx In Folders
If LCase(Folderx.Name) = LCase(email_name) Then
Set objMainFolder = Folderx.Folders("Inbox") 'adjust as required. Add more folders via .folders("name")
found_folder=1
End If
Next
if found_folder =0 then
msgbox "the email folder with the name '" & email_name & "' was not found"
exit sub
end if
Dim reloadFolder As Outlook.Folder
Dim propertyAccessor As Outlook.propertyAccessor
For Each Folderx In objMainFolder.Folders
' if there is an error, then there might not be any order data. Try reordering them manually. Also make sure loading the email as the main profile instead of as an additional mailbox.
'On Error Resume Next
Set propertyAccessor = Folderx.propertyAccessor
sort_order = propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x30200102"))
arr.Add Folderx.Name & "##~~##" & sort_order
arr_sorted.Add Folderx.Name & "##~~##" & sort_order
Next
arr.Sort 'keep A-Z (the original list from outlook isn't in A-Z order)
arr_sorted.Sort 'make A-Z
arr_sorted.Reverse 'make Z-A
Dim t, a, b, i, t2, a2, b2
i = 0
For Each arr_folder In arr
t = Split(arr_folder, "##~~##")
a = t(0) 'which folder name?
b = t(1) 'what is the original order? [should already be A-Z]
Set Folders = Application.ActiveExplorer.Session.Folders
For Each Folderx In Folders
'On Error Resume Next
If LCase(Folderx.Name) = LCase(email_name) Then
Set reloadFolder = Folderx.Folders("Inbox").Folders(a)
End If
Next
t2 = Split(arr_sorted(i), "##~~##")
a2 = t2(0) 'which folder name?
b2 = t2(1) 'what is the reversed order?
Set propertyAccessor = reloadFolder.propertyAccessor
propertyAccessor.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x30200102", propertyAccessor.StringToBinary(b2)
i = i + 1
Next
End Sub
Additional Notes: I did try experimenting with applying ordering data manually. I couldn't get it to work properly. All the binary converting code wasn't producing the correct values, and I ended up using HEX(). Here is an example of what I was doing:
Dim custom_order As Long
custom_order = 15
For Each arr_folder In arr
'the array only contains a list of folder names.. we need to load the folder in outlook to process it again. The below line of code loads the main email inbox, then the subfolder from the array [different from the above code]
Set reloadFolder = Application.Session.GetDefaultFolder(olFolderInbox).Folders(arr_folder)
Set propertyAccessor = reloadFolder.propertyAccessor
hexval = Hex(custom_order)
propertyAccessor.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x30200102", propertyAccessor.StringToBinary(hexval)
custom_order = custom_order + 1
Next
End Sub
Im trying to check if a folder exists; if it does not then create it. The below is just throwing a run-time error.
Sub AddClose()
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myNewFolder As Outlook.Folder
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
If myFolder.Folders("Close") = 0 Then
myFolder.Folders.Add("Close").Folders.Add ("EID1")
myFolder.Folders("Close").Folders.Add ("EID2")
myFolder.Folders("Close").Folders.Add ("EID3")
End If
End Sub
However, If the folder exists then the below works...
If myFolder.Folders("Close") > 0 Then
MsgBox "Yay!"
End If
Why? What can I do to correct the problem?
Firstly, you are comparing the result of the myFolder.Folders("Close") call (which is supposed to return a MAPIFolder object) with an integer (0). You need to use Is Nothing or Is Not Nothing operator.
Secondly, MAPIFolder.Folders.Item() raises an exception if the folder with a given name is not found. You need to trap that exception (as ugly as it is in VBA) and either check the Err.Number value or check that the return object is set:
On Error Resume Next
set subFolder = myFolder.Folders.Item("Close")
if subFolder Is Nothing Then
set subFolder = myFolder.Folders.Add("Close")
End If
I do not understand: If myFolder.Folders("Close") = 0 Then. myFolder.Folders("Close") is a folder and I would not have thought of comparing it against zero. Do you have a reference to a site where this functionality is explained because I would like to understand it?
I wish to create a folder if it does not exist often enough to have written a function. My function does not have ideal parameters for your requirement but it works. I offer it as tested code that does what you want or as a source of ideas for your own code.
Sub DemoGetCreateFldr shows how to use the function GetCreateFldr to achieve the effect I believe you seek.
I do not use GetDefaultFolder because, on my system, it returns a reference to a store I do not use. “Outlook Data File” is Outlook’s default store but the wizard created a separate store for each of my two email addresses. In Set Store = Session.Folders("Outlook Data File"), replace "Outlook Data File" with the name of the store holding the Inbox for which you want to create subfolders.
The first call of GetCreateFldr creates folder “Close” if it does not exist and then creates folder “EID1”. I save the reference to the folder, and use Debug.Print to demonstrate it returns the correct reference.
For folders “EID2” and “EID3”, I do not save the reference which matches your code.
If folders “Close”, “EID1”, “EID2” and “EID3” exist, GetCreateFldr does not attempt to create them although it still returns a reference.
Hope this helps.
Sub DemoGetCreateFldr()
Dim FldrEID1 As Folder
Dim FldrNameFull(1 To 3) As String
Dim Store As Folder
Set Store = Session.Folders("Outlook Data File")
FldrNameFull(1) = "Inbox"
FldrNameFull(2) = "Close"
FldrNameFull(3) = "EID1"
Set FldrEID1 = GetCreateFldr(Store, FldrNameFull)
Debug.Print FldrEID1.Parent.Parent.Parent.Name & "|" & _
FldrEID1.Parent.Parent.Name & "|" & _
FldrEID1.Parent.Name & "|" & _
FldrEID1.Name
FldrNameFull(3) = "EID2"
Call GetCreateFldr(Store, FldrNameFull)
FldrNameFull(3) = "EID3"
Call GetCreateFldr(Store, FldrNameFull)
End Sub
Public Function GetCreateFldr(ByRef Store As Folder, _
ByRef FldrNameFull() As String) As Folder
' * Store identifies the store, which must exist, in which the folder is
' wanted.
' * FldrNameFull identifies a folder which is or is wanted within Store.
' Find the folder if it exists otherwise create it. Either way, return
' a reference to it.
' * If LB is the lower bound of FldrNameFull:
' * FldrNameFull(LB) is the name of a folder that is wanted within Store.
' * FldrNameFull(LB+1) is the name of a folder that is wanted within
' FldrNameFull(LB).
' * FldrNameFull(LB+2) is the name of a folder that is wanted within
' FldrNameFull(LB+1).
' * And so on until the full name of the wanted folder is specified.
' 17Oct16 Date coded not recorded but must be before this date
Dim FldrChld As Folder
Dim FldrCrnt As Folder
Dim ChildExists As Boolean
Dim InxC As Long
Dim InxFN As Long
Set FldrCrnt = Store
For InxFN = LBound(FldrNameFull) To UBound(FldrNameFull)
ChildExists = True
' Is FldrNameFull(InxFN) a child of FldrCrnt?
On Error Resume Next
Set FldrChld = Nothing ' Ensure value is Nothing if following statement fails
Set FldrChld = FldrCrnt.Folders(FldrNameFull(InxFN))
On Error GoTo 0
If FldrChld Is Nothing Then
' Child does not exist
ChildExists = False
Exit For
End If
Set FldrCrnt = FldrChld
Next
If ChildExists Then
' Folder already exists
Else
' Folder does not exist. Create it and any children
Set FldrCrnt = FldrCrnt.Folders.Add(FldrNameFull(InxFN))
For InxFN = InxFN + 1 To UBound(FldrNameFull)
Set FldrCrnt = FldrCrnt.Folders.Add(FldrNameFull(InxFN))
Next
End If
Set GetCreateFldr = FldrCrnt
End Function
Its not a good coding practice to user on error.
I would recommend you to traverse through the folders.
Then if a certain name is not found create it.
The code below part of my macro I use.
It looks for a "Duplicates" under inbox.
It intentionally doesn't do this recursively.
Sub createDuplicatesFolder()
Dim folderObj, rootfolderObj, newfolderObj As Outlook.folder
Dim NameSpaceObj As Outlook.NameSpace
duplicatefolder = False
For Each folderObj In Application.Session.Folders
If folderObj.Name = "Duplicates" Then duplicatefolder = True
Next
If duplicatefolder = False Then
Set rootfolderObj = NameSpaceObj.GetDefaultFolder(olFolderInbox)
Set newfolderObj = rootfolderObj.Folders.Add("Duplicates")
End Sub
A slow way. Depends on number of folders.
Sub checkFolder()
Dim folderObj As folder
Dim rootfolderObj As folder
Dim newfolderObj As folder
Dim checkFolderName As String
' Check and add in the same location
Set rootfolderObj = Session.GetDefaultFolder(olFolderInbox)
' Check and add the same folder name
checkFolderName = "checkedFolder"
For Each folderObj In rootfolderObj.folders
If folderObj.name = checkFolderName Then
Set newfolderObj = rootfolderObj.folders(checkFolderName)
'Reduces the search time, if the folder exists
Exit For
End If
Next
If newfolderObj Is Nothing Then
Set newfolderObj = rootfolderObj.folders.add(checkFolderName)
End If
Debug.Print newfolderObj.name
End Sub
A fast way. Add without checking existing folders.
Sub addFolder_OnErrorResumeNext()
Dim rootFolder As folder
Dim addFolder As folder
Dim addFolderName As String
Set rootFolder = Session.GetDefaultFolder(olFolderInbox)
addFolderName = "addFolder"
On Error Resume Next
' Bypass expected error if folder exists
Set addFolder = rootFolder.folders.add(addFolderName)
' Return to normal error handling for unexpected errors
' Consider mandatory after On Error Resume Next
On Error GoTo 0
' In other cases the expected error should be handled.
' For this case it can be ignored.
Set addFolder = rootFolder.folders(addFolderName)
Debug.Print addFolder.name
End Sub
I have created a VBA subroutine to list any and all sub-folders that have "NNN" text in the name in a list-box on a userform - I have loads of sub-folders and finding the right one is therefore time consuming. This routine works perfectly.
However, what I now want to do is to double-click on a list-box item and it "selects" the folder in the folder hierarchy to save me the time to locate it manually (it could be several levels down).
I have a snippet that does this:
Public Sub GetItemsFolderPath()
Dim obj As Object
Dim F As Outlook.MAPIFolder
Dim Msg$
Set obj = Application.ActiveWindow
If TypeOf obj Is Outlook.Inspector Then
Set obj = obj.CurrentItem
Else
Set obj = obj.Selection(1)
End If
Set F = obj.Parent
Msg = "The path is: " & F.FolderPath & vbCrLf
Msg = Msg & "Switch to the folder?"
If MsgBox(Msg, vbYesNo) = vbYes Then
Set Application.ActiveExplorer.CurrentFolder = F
End If
End Sub
However, if I try and replace "F" with a folder path which is just a string, it fails.
So my question is, how can I select the folder using just a string for the folder path like "paul#anymail.com\Inbox\03_Group Finance\00_Organization Chart"
Thanks
I tried this little simple thing to return a folder from a path:
Function FolderFromPath(FolderPath As String) As Folder
Dim F As Folder
Dim arrFolders() As String
Dim i As Integer
Set myNamespace = Application.GetNamespace("MAPI")
Set F = myNamespace.GetDefaultFolder(olFolderInbox)
arrFolders = Split(FolderPath, "\")
For i = 4 To UBound(arrFolders)
Set F = F.Folders(arrFolders(i))
Next
Set FolderFromPath = F
End Function
It starts from your inbox (which perhaps isn't what you need), and then splits the path and goes into each folder in the path.
Update after comment
I forgot to show how to use it. You can do it like this:
Path = "\\first.last#company.com\Inbox\Folder1\Folder2"
Set Application.ActiveExplorer.CurrentFolder = FolderFromPath(Path)
The method described by Sam will do what you want. There is a small problem with the code. The index starts to far along the path. 4 should be 2 if the initial reference is to the Inbox.
Function FolderFromPath(FolderPath As String) As Folder
Dim F As Folder
Dim arrFolders() As String
Dim i As Long
arrFolders = Split(FolderPath, "\")
' Initial reference is to the mailbox - array element 0
Set F = Session.Folders(arrFolders(0))
' The next folder is array element 1
For i = LBound(arrFolders) + 1 To UBound(arrFolders)
Set F = F.Folders(arrFolders(i))
Next
Set FolderFromPath = F
End Function
Public Sub GetItemsFolderPath_Test()
Dim FPath As String
FPath = "paul#anymail.com\Inbox\03_Group Finance\00_Organization Chart"
Set ActiveExplorer.CurrentFolder = FolderFromPath(FPath)
End Sub
I have a listener in VBA on my outlook box to perform an action if a receive a mail from a specific email.
The problem is that if I get a error mail (non-delivery email) then my condition is run on a mail which doesn't have that property so my method crashes.
I don't know what the subject may be either.
Does anyone have an idea if I can test if the property exists or if there is another property I can check for to identify if my sender matches?
Many thanks in advance
Sub SetFlagIcon()
Dim mpfInbox As Outlook.Folder
Dim obj As Outlook.MailItem
Dim i As Integer
Set mpfInbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Test")
' Loop all items in the Inbox\Test Folder
For i = 1 To mpfInbox.Items.Count
If mpfInbox.Items(i).Class = olMail Then
Set obj = mpfInbox.Items.Item(i)
If obj.SenderEmailAddress = "someone#example.com" Then
'Set the yellow flag icon
obj.FlagIcon = olYellowFlagIcon
obj.Save
End If
End If
Next
End Sub
Dim obj as a generic Object - there are objects other than MailItem in your Inbox, also to improve your loop try using Items.Restrict Method (Outlook)
Option Explicit
Sub SetFlagIcon()
Dim mpfInbox As Outlook.Folder
Dim obj As Object
Dim Items As Outlook.Items
Dim i As Long
Dim Filter As String
Set mpfInbox = Application.GetNamespace("MAPI").GetDefaultFolder _
(olFolderInbox).Folders("Temp")
Filter = "[SenderEmailAddress] = 'someone#example.com'"
Set Items = mpfInbox.Items.Restrict(Filter)
' Loop all items in the Inbox\Test Folder
For i = 1 To Items.Count
If Items(i).Class = olMail Then
Set obj = Items(i)
'Set the yellow flag icon
obj.FlagIcon = olYellowFlagIcon
obj.Save
End If
Next
End Sub
Items.Restrict Method Applies a filter to the Items collection, returning a new collection containing all of the items from the original that match the filter.