PDA

View Full Version : Search folder and move the item



nymphe1410
01-06-2021, 05:01 PM
Hello everyone,

I've tried to read all topics with "move" item to folders but unfortunately despite trying to modify and adapt those codes, I failed.

There was one post which was similar to my folder structure but still was not the answer I was looking for. Almost all posts about moving are trying to move objects to predefined folders. Those are hard coded into the script, but I need to have the path as a variable.

I'm working in project business, so for each quotation and order I have subfolders. Those are also nested under further parent folders like year or country. Basically I want to keep all relevant emails of a particular job in a separate Outlook folder. Of course now I have hundred of folders.

I'm using a macro for finding those folders. I think this is quite popular and well known macro, which can be found below.

What I want is to extend this macro to move the email I select to the found folder above. This can be an extension or also secondary macro to run. For example:

Run the macro: Find folder with the name *jobsite*. Get path of this folder. Move the active item (email) to this folder (Job123-jobsite-xyz).

When I set the m_Folders variable as Outlook.Folders I always get errors. Basically the code works until move command.

Thank you very much for helping or at least reading it.

My code is:
Part I: For finding folders only. Works perfectly and quite fast too.



Private m_Folder As Outlook.MAPIFolder
Private m_Find As String
Private m_Wildcard As Boolean

Private Const SpeedUp As Boolean = False
Private Const StopAtFirstMatch As Boolean = True

Public Sub FindFolder()
Dim Name$
Dim Folders As Outlook.Folders
Dim m_Folder2 As Outlook.MAPIFolder
Dim m_Folder3 As String

'additions for move to folder

Set m_Folder = Nothing
m_Find = ""
m_Wildcard = False

Name = InputBox("Find name:", "Search folder")
If Len(Trim$(Name)) = 0 Then Exit Sub
m_Find = "*" & Name & "*"

m_Find = LCase$(m_Find)
m_Find = Replace(m_Find, "%", "*")
m_Wildcard = (InStr(m_Find, "*"))

Set Folders = Application.Session.Folders
LoopFolders Folders

If Not m_Folder Is Nothing Then

If MsgBox("Activate folder: " & vbCrLf & m_Folder.FolderPath, vbQuestion Or vbYesNo) = vbYes Then


'activate the folder:

Set Application.ActiveExplorer.CurrentFolder = m_Folder

Else
' **** don't go to the folder, instead move the item - basically this is what I'm trying ****

Set m_Folder2 = m_Folder

MoveCopyMessage (m_Folder2)

End If
Else
MsgBox "Not found", vbInformation
End If
End Sub

Private Sub LoopFolders(Folders As Outlook.Folders)
Dim F As Outlook.MAPIFolder
Dim Found As Boolean

If SpeedUp = False Then DoEvents

For Each F In Folders
If m_Wildcard Then
Found = (LCase$(F.Name) Like m_Find)
Else
Found = (LCase$(F.Name) = m_Find)
End If

If Found Then
If StopAtFirstMatch = False Then
If MsgBox("Found: " & vbCrLf & F.FolderPath & vbCrLf & vbCrLf & "Continue?", vbQuestion Or vbYesNo) = vbYes Then
Found = False
End If
End If
End If
If Found Then
Set m_Folder = F
Exit For
Else
LoopFolders F.Folders
If Not m_Folder Is Nothing Then Exit For
End If
Next
End Sub


Part II: Move the item to above found folder. This is a macro which I found somewhere else too. I played around so there are unnecessary parts left. I think I fail to the integrate the destination folder in this script. I tried to play with m_Folder.FolderPath but objItem.Move doesn't recognize it.



Sub MoveCopyMessage(m_Folder2)

Dim objNS As Outlook.NameSpace
Dim objDestFolder As Outlook.MAPIFolder
Dim objItem As Outlook.MailItem
Dim objCopy As Outlook.MailItem

Set objNS = Application.GetNamespace("MAPI")

' Set the destination folders
' Set objDestFolder = objNS.Folders("Public Folders - alias-domain") _
.Folders("All Public Folders").Folders("Old")

Set objItem = Application.ActiveExplorer.Selection.Item(1)

' move to a subfolder of the Inbox

' Set objDestFolder = m_Folder2

' copy and move first - I'm trying to see whether this works, for now, it is copying the email successfully
Set objCopy = objItem.Copy
objCopy.Move m_Folder2
' to move
' objItem.Move objDestFolder


Set objDestFolder = Nothing
Set objNS = Nothing
End Sub


One more thanks if you read until here :)

nymphe1410
01-07-2021, 08:19 AM
Hi, it seems the solution is easier than I thought. I still don't understand why it doesn't work with two parts, but when I integrate the code at Part II into first part, it works and moves the emails to found folder.

Below the working version, which I cleaned a bit.





Option Explicit
Private m_Folder As Outlook.MAPIFolder
Private m_Find As String
Private m_Wildcard As Boolean


Private Const SpeedUp As Boolean = False
Private Const StopAtFirstMatch As Boolean = True


Public Sub FindFolder()
Dim Name$
Dim Folders As Outlook.Folders

'additons for move to folder
Dim objNS As Outlook.NameSpace
Dim objItem As Outlook.MailItem
Set objNS = Application.GetNamespace("MAPI")
Set objItem = Application.ActiveExplorer.Selection.Item(1)
'additions for move to folder


Set m_Folder = Nothing
m_Find = ""
m_Wildcard = False


Name = InputBox("Find folder by name:", "Search folder & Move Item")
If Len(Trim$(Name)) = 0 Then Exit Sub
m_Find = "*" & Name & "*" '<--- good addition so that we don't need to add * everytime.


m_Find = LCase$(m_Find)
m_Find = Replace(m_Find, "%", "*")
m_Wildcard = (InStr(m_Find, "*"))


Set Folders = Application.Session.Folders
LoopFolders Folders


If Not m_Folder Is Nothing Then

If MsgBox("Activate folder or just move the item to it: " & vbCrLf & vbCrLf & m_Folder.FolderPath & vbNewLine & vbNewLine & "Yes = Activate the folder only" & vbNewLine & "No = Move the item and activate", vbQuestion Or vbYesNo) = vbYes Then

'only activate the folder:

Set Application.ActiveExplorer.CurrentFolder = m_Folder

Else
' move the item to the found folder and activate to be sure:


objItem.Move m_Folder '<-- where magic happens :)


Set Application.ActiveExplorer.CurrentFolder = m_Folder '<-- this line can be deactivated if not needed.

End If
Else
MsgBox "Not found", vbInformation
End If
End Sub


Private Sub LoopFolders(Folders As Outlook.Folders)
Dim F As Outlook.MAPIFolder
Dim Found As Boolean

If SpeedUp = False Then DoEvents


For Each F In Folders
If m_Wildcard Then
Found = (LCase$(F.Name) Like m_Find)
Else
Found = (LCase$(F.Name) = m_Find)
End If


If Found Then
If StopAtFirstMatch = False Then
If MsgBox("Found: " & vbCrLf & F.FolderPath & vbCrLf & vbCrLf & "Continue?", vbQuestion Or vbYesNo) = vbYes Then
Found = False
End If
End If
End If
If Found Then
Set m_Folder = F
Exit For
Else
LoopFolders F.Folders
If Not m_Folder Is Nothing Then Exit For
End If
Next
End Sub

ashringg
11-14-2023, 10:26 AM
Hi Nymphe1410,

Thank you for your code. This code has been working for me for 2 weeks now and it has helped me tremendously but all of a sudden it no longer works. My trust center has macros enabled, I restarted the program, deleted the macro, and even changed the project name. The window would pop up to find the folder but it does not provide the follow-up path to go to the folder or move then go to the folder. Do you have any suggestions?



Hi, it seems the solution is easier than I thought. I still don't understand why it doesn't work with two parts, but when I integrate the code at Part II into first part, it works and moves the emails to found folder.

Below the working version, which I cleaned a bit.





Option Explicit
Private m_Folder As Outlook.MAPIFolder
Private m_Find As String
Private m_Wildcard As Boolean


Private Const SpeedUp As Boolean = False
Private Const StopAtFirstMatch As Boolean = True


Public Sub FindFolder()
Dim Name$
Dim Folders As Outlook.Folders

'additons for move to folder
Dim objNS As Outlook.NameSpace
Dim objItem As Outlook.MailItem
Set objNS = Application.GetNamespace("MAPI")
Set objItem = Application.ActiveExplorer.Selection.Item(1)
'additions for move to folder


Set m_Folder = Nothing
m_Find = ""
m_Wildcard = False


Name = InputBox("Find folder by name:", "Search folder & Move Item")
If Len(Trim$(Name)) = 0 Then Exit Sub
m_Find = "*" & Name & "*" '<--- good addition so that we don't need to add * everytime.


m_Find = LCase$(m_Find)
m_Find = Replace(m_Find, "%", "*")
m_Wildcard = (InStr(m_Find, "*"))


Set Folders = Application.Session.Folders
LoopFolders Folders


If Not m_Folder Is Nothing Then

If MsgBox("Activate folder or just move the item to it: " & vbCrLf & vbCrLf & m_Folder.FolderPath & vbNewLine & vbNewLine & "Yes = Activate the folder only" & vbNewLine & "No = Move the item and activate", vbQuestion Or vbYesNo) = vbYes Then

'only activate the folder:

Set Application.ActiveExplorer.CurrentFolder = m_Folder

Else
' move the item to the found folder and activate to be sure:


objItem.Move m_Folder '<-- where magic happens :)


Set Application.ActiveExplorer.CurrentFolder = m_Folder '<-- this line can be deactivated if not needed.

End If
Else
MsgBox "Not found", vbInformation
End If
End Sub


Private Sub LoopFolders(Folders As Outlook.Folders)
Dim F As Outlook.MAPIFolder
Dim Found As Boolean

If SpeedUp = False Then DoEvents


For Each F In Folders
If m_Wildcard Then
Found = (LCase$(F.Name) Like m_Find)
Else
Found = (LCase$(F.Name) = m_Find)
End If


If Found Then
If StopAtFirstMatch = False Then
If MsgBox("Found: " & vbCrLf & F.FolderPath & vbCrLf & vbCrLf & "Continue?", vbQuestion Or vbYesNo) = vbYes Then
Found = False
End If
End If
End If
If Found Then
Set m_Folder = F
Exit For
Else
LoopFolders F.Folders
If Not m_Folder Is Nothing Then Exit For
End If
Next
End Sub

jdelano
11-15-2023, 05:50 AM
Have you tried to debug your code to see if it is being called at all? VBA: How to Debug Code - Overview, Tools, Shortcut Keys | Wall Street Oasis (https://www.wallstreetoasis.com/resources/excel/study/vba-how-to-debug-code)

ashringg
11-16-2023, 01:45 PM
I tried going through the steps. Nothing. I think it timed out and i received an "array index out of bounds outlook".