Outlook Filing Macro.

Macro 1 will jump directly to the folder based on your search input.

Option Explicit

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

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



Public Sub GotoFolder()
Dim sName As String
Dim oFolders As Folders

  Set m_Folder = Nothing
m_Find = ""
m_Wildcard = False

sName = InputBox("Find:", "Search folder")
If Len(Trim(sName)) = 0 Then Exit Sub

m_Find = sName & "*"

BroadenSearch:

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

  Set oFolders = Application.Session.Folders
LoopFolders oFolders

If Not m_Folder Is Nothing Then
    If MsgBox("This Folder: " & vbCrLf & GetRightFolder(m_Folder.FolderPath), vbQuestion Or vbYesNo) = vbYes Then
        Set Application.ActiveExplorer.CurrentFolder = m_Folder
    Else
        If MsgBox("Broaden search?", vbQuestion Or vbYesNo) = vbYes Then
            m_Find = "*" & sName & "*"
            GoTo BroadenSearch
        Else
            Exit Sub
        End If
    End If
Else
    If MsgBox("Folder not found. Broaden search?", vbQuestion Or vbYesNo) = vbYes Then
            m_Find = "*" & sName & "*"
            GoTo BroadenSearch
        Else
        MsgBox "Folder not found!!"
            Exit Sub
    End If
End If

End Sub


Private Sub LoopFolders(Folders As Outlook.Folders)
Dim oFolder As MAPIFolder
Dim bFound As Boolean

If SpeedUp = False Then DoEvents

  For Each oFolder In Folders
If m_Wildcard Then
bFound = (LCase(oFolder.Name) Like m_Find)
Else
bFound = (LCase(oFolder.Name) = m_Find)
End If

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

End Sub

Macro 2 will file the selected mail item(s) directly into the searched folder, without changing the screen focus.

Option Explicit

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

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



Public Sub FindFolder()
Dim sName As String
Dim oFolders As Folders

  Set m_Folder = Nothing
m_Find = ""
m_Wildcard = False

sName = InputBox("Find:", "Search folder")
If Len(Trim(sName)) = 0 Then Exit Sub

m_Find = sName & "*"

BroadenSearch:

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

  Set oFolders = Application.Session.Folders
LoopFolders oFolders

If Not m_Folder Is Nothing Then
    If MsgBox("This Folder: " & vbCrLf & GetRightFolder(m_Folder.FolderPath), vbQuestion Or vbYesNo) = vbYes Then
        'Set Application.ActiveExplorer.CurrentFolder = m_Folder
    Else
        If MsgBox("Move cancelled. Broaden search?", vbQuestion Or vbYesNo) = vbYes Then
            m_Find = "*" & sName & "*"
            GoTo BroadenSearch
        Else
            Exit Sub
        End If
    End If
Else
    If MsgBox("Folder not found. Broaden search?", vbQuestion Or vbYesNo) = vbYes Then
            m_Find = "*" & sName & "*"
            GoTo BroadenSearch
        Else
            MsgBox "Folder not found!!"
            Exit Sub
    End If
End If


'This section moves the selected item to the folder
Dim oNamespace As Outlook.NameSpace, oSelection As Outlook.Selection
  Dim oFolder As Outlook.MAPIFolder
  Dim oItem As Object, i As Integer

  Set oNamespace = Application.GetNamespace("MAPI")

  Set oSelection = oNamespace.Application.ActiveExplorer.Selection
  If oSelection.Count < 1 Then Exit Sub

  'Set oFolder = FindFolder
  'If oFolder Is Nothing Then Exit Sub

  ' move items
  For i = 1 To oSelection.Count
    Set oItem = oSelection.Item(i)
    If Not oItem.Parent = m_Folder Then
      oSelection.Item(i).Move m_Folder
    End If
  Next i




End Sub




Private Sub LoopFolders(Folders As Outlook.Folders)
Dim oFolder As MAPIFolder
Dim bFound As Boolean

If SpeedUp = False Then DoEvents

  For Each oFolder In Folders
If m_Wildcard Then
bFound = (LCase(oFolder.Name) Like m_Find)
Else
bFound = (LCase(oFolder.Name) = m_Find)
End If

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

End Sub

Function GetRightFolder(fname) As String
    Dim a
    a = Split(fname, "")
    GetRightFolder = a(UBound(a))
End Function