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.
Related
I have the below code to permanently delete mail from the inbox.
However, when responses to a meeting invite, to say the person has accepted the meeting do not delete.
When I click on that mail and run this code it does not delete?
Sub PermDelete(Item As Outlook.MailItem)
' First set a property to find it again later
Item.UserProperties.Add "Deleted", olText
Item.Save
Item.Delete
'Now go through the deleted folder, search for the property and delete item
Dim objDeletedFolder As Outlook.Folder
Dim objItem As Object
Dim objProperty As Variant
Set objDeletedFolder = Application.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderDeletedItems)
For Each objItem In objDeletedFolder.items
Set objProperty = objItem.UserProperties.Find("Deleted")
If TypeName(objProperty) <> "Nothing" Then
objItem.Delete
End If
Next
End Sub
To run code that has an argument like (Item As Outlook.MailItem) you need to pass the information in this case Item.
You cannot run such code from a button.
You can run Sub delItemPermanently() from a button or F8 to step through.
Option Explicit
Sub delItemPermanently()
' Select a single item
' This line passes the item to PermDelete
PermDelete ActiveExplorer.Selection(1)
End Sub
Sub PermDelete(Item As Object)
' Notice Object not Mailitem
' This will accommodate mailitems as well
...
End Sub
In the code your function accepts an instance of the MailItem class only. But an Outlook folder may contain different types of items - appointments, documents, notes and etc. To differentiate them at runtime you can use the following construction:
Dim obj As Object
If TypeName(obj) = "MailItem" Then
' your code for mail items here
End If
So, you need to declare the function in the following way (if you don't need to do separate actions for different kind of items):
Sub PermDelete(Item As Object)
' First set a property to find it again later
Item.UserProperties.Add "Deleted", olText
Item.Save
Item.Delete
'Now go through the deleted folder, search for the property and delete item
Dim objDeletedFolder As Outlook.Folder
Dim objItem As Object
Dim objProperty As Variant
Set objDeletedFolder = Application.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderDeletedItems)
For Each objItem In objDeletedFolder.items
Set objProperty = objItem.UserProperties.Find("Deleted")
If TypeName(objProperty) <> "Nothing" Then
objItem.Delete
End If
Next
End Sub
Set Item to a generic Object
Example on selected item
Option Explicit
Public Sub Example()
Dim obj As Object
Set obj = ActiveExplorer.Selection.Item(1)
obj.Delete
End Sub
I'm trying to add a category to every email selected in Outlook using VBA.
The problem is that the code below adds the category only to the first email.
I'm using Outlook 2016.
Public Sub MarkSelectedAsGreenCategory()
Dim olItem As MailItem
Dim newCategory As String
newCategory = "Green category"
Dim i As Integer
For i = 1 To Application.ActiveExplorer.Selection.Count
Set olItem = Application.ActiveExplorer.Selection(i)
AddCategory olItem, newCategory
Set olItem = Nothing
Next
End Sub
Private Sub AddCategory(mailItem As mailItem, newCategory As String)
Dim categories() As String
Dim listSep As String
' Get the current list separator from Windows regional settings
listSep = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\International\sList")
' Break the list up into an array
categories = Split(mailItem.categories, listSep)
' Search the array for the new category, and if it is missing, then add it
If UBound(Filter(categories, newCategory)) = -1 Then
ReDim Preserve categories(UBound(categories) + 1)
categories(UBound(categories)) = newCategory
mailItem.categories = Join(categories, listSep)
End If
End Sub
An update to a category on ActiveInspector.CurrentItem would generate a prompt to save.
For a selection:
olItem.Save or mailItem.Save at your convenience.
This question already has answers here:
How can I compare all the titles of all RSS feeds and delete duplicates?
(2 answers)
Closed 5 years ago.
I'm wondering if there is a way to compare ALL TITLES in ALL RSS FEEDS and delete the duplicates.
I read through a lot of RSS Feeds, and it's obvious that a lot of people cross-post to several forums, and then I end up seeing the same RSS Feed multiple times.
I really just want to see each one one single time. Is there a way to list all feeds, and delete duplicates, if I actually have duplicates in my entire MS Outlook RSS Feed list?
Here's 0m3r's script, modified slightly.
Option Explicit
Public Sub Example()
Dim olNs As Outlook.NameSpace
Dim RSS_Folder As Outlook.MAPIFolder
Dim Item As Object
Dim Items As Items
Dim DupItem As Object
Dim i As Long
Dim j As Long
For j = 1 To 21
Set olNs = Application.GetNamespace("MAPI")
Set RSS_Folder = olNs.GetDefaultFolder(olFolderRssFeeds).Folders(j)
Set DupItem = CreateObject("Scripting.Dictionary")
Set Items = RSS_Folder.Items
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is PostItem Then
Set Item = Items(i)
If DupItem.Exists(Item.Subject) Then
Debug.Print Item.Subject ' Print on Immediate Window
Debug.Print TypeName(Item) ' Print on Immediate Window
Item.Delete
Else
'Debug.Print Item.Subject
DupItem.Add Item.Subject, 0
End If
End If
Next i
Debug.Print RSS_Folder
Next j
Set olNs = Nothing
Set RSS_Folder = Nothing
Set Item = Nothing
Set Items = Nothing
Set DupItem = Nothing
End Sub
Iterating over all items in the folder is not really a good idea.
For Each myItem In subFolder.Items
If InStr(myItem.Subject, "[on hold]") > 0 Then
You can use the Find/FindNext or Restrict methods of the Items class to find all items that correspond to your conditions. Read more about them in the following articles:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
Also you may find the AdvancedSearch method of the Application class helpful.
The key benefits of using the AdvancedSearch method in Outlook are:
The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
Finally, you can stop the search process at any moment using the Stop method of the Search class.
Read more about that in the Advanced search in Outlook programmatically: C#, VB.NET article.
Work with Dictionary Object to compare Items.Subject in your olFolderRssFeeds
Dictionary in VBA is a collection-object:
you can store all kinds of things in it: numbers, texts, dates, arrays, ranges, variables and objects, Every item in a Dictionary gets its own unique key and
With that key you can get direct access to the item (reading/writing).
Here is quick Example code
Option Explicit
Public Sub Example()
Dim olNs As Outlook.NameSpace
Dim RSS_Folder As Outlook.MAPIFolder
Dim Item As Object
Dim Items As Items
Dim DupItem As Object
Dim i As Long
Set olNs = Application.GetNamespace("MAPI")
Set RSS_Folder = olNs.GetDefaultFolder(olFolderRssFeeds) _
.Folders("Microsoft At Home")
Set DupItem = CreateObject("Scripting.Dictionary")
Set Items = RSS_Folder.Items
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is PostItem Then
Set Item = Items(i)
If DupItem.Exists(Item.subject) Then
Debug.Print Item.subject ' Print on Immediate Window
Debug.Print TypeName(Item) ' Print on Immediate Window
' Item.Delete
Else
DupItem.Add Item.subject, 0
End If
End If
Next i
Set olNs = Nothing
Set RSS_Folder = Nothing
Set Item = Nothing
Set Items = Nothing
Set DupItem = Nothing
End Sub
This Example shows how to process all Folders under RSS Feed Folders
Option Explicit
Public Sub DupeRSS()
Dim olNs As Outlook.NameSpace
Dim RSS_Folder As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set RSS_Folder = olNs.GetDefaultFolder(olFolderRssFeeds)
' // Process Current Folder
Example RSS_Folder
End Sub
Public Sub Example(ByVal ParentFolder As Outlook.MAPIFolder)
Dim Folder As Outlook.MAPIFolder
Dim Item As Object
Dim DupItem As Object
Dim Items As Items
Dim i As Long
Set DupItem = CreateObject("Scripting.Dictionary")
Set Items = ParentFolder.Items
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is PostItem Then
Set Item = Items(i)
If DupItem.Exists(Item.subject) Then
Debug.Print Item.subject ' Print on Immediate Window
Debug.Print TypeName(Item) ' Print on Immediate Window
Item.Delete
Else
DupItem.Add Item.subject, 0
End If
End If
Next i
' // Recurse through subfolders
If ParentFolder.Folders.Count > 0 Then
For Each Folder In ParentFolder.Folders
Example Folder
Debug.Print Folder.Name
Next
End If
Set Folder = Nothing
Set Item = Nothing
Set Items = Nothing
Set DupItem = Nothing
End Sub
Remember the code will only compare duplicate in single folder
I use the Application_ItemSend event to trigger actions on mails I send.
Under certain conditions the mail shall be moved to a new subfolder.
Since one can't move the mail before it is sent without jeopardizing the send, I copy the mail before sending and delete the original after.
Set myCopiedItem = objItem.Copy
myCopiedItem.Move olTempFolder
myCopiedItem.UnRead = False
myCopiedItem.SentOnBehalfOfName = olSession.CurrentUser
myCopiedItem.SendUsingAccount = olSession.Accounts(1)
'myCopiedItem.SenderName = olSession.CurrentUser
'myCopiedItem.SenderEmailAddress = olSession.CurrentUser.Address
objItem.DeleteAfterSubmit = True
I would like to have me as a sender on the copied mail.
I tried to set several different properties:
.SendOnBehalfOfName and .SendUsingAccount do not do what I am after.
.SenderName and .SenderEmailAddress showed to be "read only"
How can I avoid that the mail shows up in the folder without a sender?
Would this work for you:
Save the email in the Application_ItemSend event first:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Item.Save
MoveEmail Item, "\\Mailbox - Darren Bartrup-Cook\Inbox\Some Folder\Some Sub Folder"
End Sub
In a separate module (excuse MoveEmail being a function - originally it returned the EmailID of the moved email):
'----------------------------------------------------------------------------------
' Procedure : MoveEmail
' Author : Darren Bartrup-Cook
' Date : 03/07/2015
'-----------------------------------------------------------------------------------
Public Function MoveEmail(oItem As Object, sTo As String) As String
Dim oNameSpace As Outlook.NameSpace
Dim oDestinationFolder As Outlook.MAPIFolder
Set oNameSpace = Application.GetNamespace("MAPI")
Set oDestinationFolder = GetFolderPath(sTo)
oItem.Move oDestinationFolder
End Function
'----------------------------------------------------------------------------------
' Procedure : GetFolderPath
' Author : Diane Poremsky
' Original : http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/
'-----------------------------------------------------------------------------------
Function GetFolderPath(ByVal FolderPath As String) As Outlook.MAPIFolder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function
Firstly, Move is a function, not a sub - it returns the newly created item. The original must be immediately discarded.
set myCopiedItem = myCopiedItem.Move(olTempFolder)
Secondly, sender related properties are set only after the message is sent and moved to the Sent Items folder. One solution is to wait until the Items.ItemAdd event fires on the Sent Items folder and make a copy then - the sender properties will be set by that time.
In theory, you can set a dozen or so PR_SENDER_* and PR_SENT_REPRESENTING_* MAPI properties, but if I remember my experiments correctly, MailItem.PropertyAccessor.SetProperty will not let you set sender related properties. If using Redemption is an option (I am its author), it allows to set the RDOMail.Sender and RDOMail.SentOnBehalfOf properties to an instance of an RDOAddressEntry object (such as that returned by RDOSession.CurrentUser).
I am attempting to code a way to automate filing of emails. I file all of my emails in a pretty detailed set of sub-folders in my inbox. I have MANY subfolders that help me organize my emails but this leads to a lot of extra time being spent in cleaning out my inbox (by filing emails to the relevant sub-folder). I would like to automate this so that I can select an email in my inbox and run the macro to display a list of folders that emails in the same conversation thread have already been filed in and allow me to select which one to save the selected email to. I have found several sample codes that are close but nothing that really does this action.
http://blog.saieva.com/2010/03/27/move-messages-to-folders-with-outlook-vba/
shows how to move messages to sub-folders when you know what sub-folder you want the email to go to. This doesn't work for my situation because I want the macro to give me a list of "recommended" folders.
I thought the below code may be a good place to start if I could figure out a way to loop through each "child" (not sure if that is the right word) of the conversation for the selected email and move the selected to the folder if the user selects "Yes" in the MsgBox.
Public Sub GetItemsFolderPath()
Dim obj As Object
Dim F As Outlook.MAPIFolder
Dim convItemFolders As Outlook.MAPIFolder
Dim msg$
Dim rootitemcount
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 & rootitemcount & vbCrLf
msg = msg & "Switch to the folder?"
If MsgBox(msg, vbYesNo) = vbYes Then
Set Application.ActiveExplorer.CurrentFolder = F
End If
End Sub
I am having trouble putting together the loop that could make this work. Does anyone have any suggestions for how to use the above or any other options?
Edit
Not sure really how to show my next steps on this without "answering" my own question. This is my first question so I don't know all of the rules yet, if this is wrong please let me know so I can fix it. I'm not fully finished but I've gotten a lot closer with the help of the below answer. Below is my updated code:
Public Sub GetConverstationInformation()
Dim host As Outlook.Application
Set host = ThisOutlookSession.Application
' Check for Outlook 2010
If Left(host.Version, 2) = "14" Then
Dim selectedItem As Object
Dim theMailItem As Outlook.mailItem
' Get the user's currently selected item.
Set selectedItem = host.ActiveExplorer.Selection.item(1)
' Check to see if the item is a MailItem.
If TypeOf selectedItem Is Outlook.mailItem Then
Set theMailItem = selectedItem
' Check to see that the item's current folder
' has conversations enabled.
Dim parentFolder As Outlook.folder
Dim parentStore As Outlook.store
Set parentFolder = theMailItem.Parent
Set parentStore = parentFolder.store
If parentStore.IsConversationEnabled Then
' Try and get the conversation.
Dim theConversation As Outlook.conversation
Set theConversation = theMailItem.GetConversation
If Not IsNull(theConversation) Then
' Outlook provides a table object
' the contains all of the items in the
' conversation.
Dim itemsTable As Outlook.table
Set itemsTable = theConversation.GetTable
' Get the Root Items
' Enumerate the list of items
' only writing out data for MailItems.
' A conversation can contain other items
' like MeetingItems.
' Then use a helper method and recursion
' to walk all the items in the conversation.
Dim group As Outlook.simpleItems
Set group = theConversation.GetRootItems
Dim obj As Object
Dim fld As Outlook.folder
Dim mi As Outlook.mailItem
'Dim i As Long
For Each obj In group
If TypeOf obj Is Outlook.mailItem Then
Set mi = obj
Set fld = mi.Parent
'For i = 1 To group.Count
Me.ListBox1.AddItem fld.Name
'mi.Sender & _
'" sent the message '" & mi.Subject & _
'"' which is in '" &
'& "'."
'Next i
End If
GetConversationDetails mi, theConversation
Next obj
Else
MsgBox "The currently selected item is not a part of a conversation."
End If
Else
MsgBox "The currently selected item is not in a folder with conversations enabled."
End If
Else
MsgBox "The currently selected item is not a mail item."
End If
Else
MsgBox "This code only works with Outlook 2010."
End If
End Sub
Private Sub GetConversationDetails(anItem As Object, theConversation As Outlook.conversation)
Dim group As Outlook.simpleItems
Set group = theConversation.GetChildren(anItem)
If group.Count > 0 Then
Dim obj As Object
Dim fld As Outlook.folder
Dim mi As Outlook.mailItem
'Dim i As Long
'For i = 1 To group.Count(obj)
For Each obj In group
If TypeOf obj Is Outlook.mailItem Then
Set mi = obj
Set fld = mi.Parent
'Dim counter
Me.ListBox1.AddItem fld.Name
'mi.Sender & _
'" sent the message '" & mi.Subject & _
'"' which is in '" &
'& "'."
End If
GetConversationDetails mi, theConversation
Next obj
'Next i
End If
End Sub
Private Sub UserForm_Initialize()
GetConverstationInformation
End Sub
I dropped this into a userform with a listbox. My intention is to allow only unique folder names to be added. Once that is accomplished I would like to add a button that can be clicked to file the selected email in the folder chosen from the listbox. Does anyone have any notes/good starting places on these next steps? I have been searching online for different ways to do this but I keep coming across long sub's and I have to imagine there is a more elegant solution. I'll update again if I find something that works. Thanks again for your help!
It looks like you are interested in the GetConversation method which returns a Conversation object that represents the conversation to which this item belongs.
Private Sub DemoConversation()
Dim selectedItem As Object = Application.ActiveExplorer().Selection(1)
' For this example, you will work only with
'MailItem. Other item types such as
'MeetingItem and PostItem can participate
'in Conversation.
If TypeOf selectedItem Is Outlook.MailItem Then
' Cast selectedItem to MailItem.
Dim mailItem As Outlook.MailItem = TryCast(selectedItem, Outlook.MailItem)
' Determine store of mailItem.
Dim folder As Outlook.Folder = TryCast(mailItem.Parent, Outlook.Folder)
Dim store As Outlook.Store = folder.Store
If store.IsConversationEnabled = True Then
' Obtain a Conversation object.
Dim conv As Outlook.Conversation = mailItem.GetConversation()
' Check for null Conversation.
If conv IsNot Nothing Then
' Obtain Table that contains rows
' for each item in Conversation.
Dim table As Outlook.Table = conv.GetTable()
Debug.WriteLine("Conversation Items Count: " + table.GetRowCount().ToString())
Debug.WriteLine("Conversation Items from Table:")
While Not table.EndOfTable
Dim nextRow As Outlook.Row = table.GetNextRow()
Debug.WriteLine(nextRow("Subject") + " Modified: " + nextRow("LastModificationTime"))
End While
Debug.WriteLine("Conversation Items from Root:")
' Obtain root items and enumerate Conversation.
Dim simpleItems As Outlook.SimpleItems = conv.GetRootItems()
For Each item As Object In simpleItems
' In this example, enumerate only MailItem type.
' Other types such as PostItem or MeetingItem
' can appear in Conversation.
If TypeOf item Is Outlook.MailItem Then
Dim mail As Outlook.MailItem = TryCast(item, Outlook.MailItem)
Dim inFolder As Outlook.Folder = TryCast(mail.Parent, Outlook.Folder)
Dim msg As String = mail.Subject + " in folder " + inFolder.Name
Debug.WriteLine(msg)
End If
' Call EnumerateConversation
' to access child nodes of root items.
EnumerateConversation(item, conv)
Next
End If
End If
End If
End Sub
Private Sub EnumerateConversation(item As Object, conversation As Outlook.Conversation)
Dim items As Outlook.SimpleItems = conversation.GetChildren(item)
If items.Count > 0 Then
For Each myItem As Object In items
' In this example, enumerate only MailItem type.
' Other types such as PostItem or MeetingItem
' can appear in Conversation.
If TypeOf myItem Is Outlook.MailItem Then
Dim mailItem As Outlook.MailItem = TryCast(myItem, Outlook.MailItem)
Dim inFolder As Outlook.Folder = TryCast(mailItem.Parent, Outlook.Folder)
Dim msg As String = mailItem.Subject + " in folder " + inFolder.Name
Debug.WriteLine(msg)
End If
' Continue recursion.
EnumerateConversation(myItem, conversation)
Next
End If
End Sub
Thanks for your hard work! I wanted the same functionality and expanded on your code to add a listbox to select a folder and only allow unique folder names to be added to the listbox. I also added code to move the emails after a folder is selected. The finished code is working in Outlook 2016 and hosted on GitHub since listbox files are stored as binaries and cannot be shown here.
GitHub: outlook-move-to-thread
To update listbox and not allow duplicates in GetConversationInformation(),
For Each obj In group
If TypeOf obj Is Outlook.mailItem Then
' If ROOT item is an email, add it to ListBox1
Set mi = obj
Set fld = mi.Parent
' Don't include duplicate folders
IsInListBox = False
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Column(0, i) = fld.FolderPath Then
IsInListBox = True
End If
Next
If (InStr(fld.FolderPath, "Inbox") = 0) And _
(InStr(fld.FolderPath, "Sent Items") = 0) And _
(IsInListBox = False) Then
Me.ListBox1.AddItem fld.FolderPath
End If
End If
GetConversationDetails mi, theConversation
Next obj
To update listbox and not allow duplicates in GetConversationDetails(),
' Don't include generic folders
If (InStr(fld.FolderPath, "Inbox") = 0) And _
(InStr(fld.FolderPath, "Sent Items") = 0) Then
' Don't include duplicate folders
IsInListBox = False
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Column(0, i) = fld.FolderPath Then
IsInListBox = True
End If
Next
' Add to ListBox1
If IsInListBox = False Then
Me.ListBox1.AddItem fld.FolderPath
End If
End If