Search folder and move the item

[nymphe1410]

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