Option Explicit

' ===========================
'   CONFIGURATION
' ===========================
' Name of the custom user property for domains
Public Const DOMAIN_FIELD_NAME As String = "Domain"

' Folder index behavior
Public Const SEARCH_ALL_STORES As Boolean = False       ' Default mailbox only for speed
Public Const INDEX_REBUILD_MINUTES As Long = 60         ' Auto-rebuild after N minutes
Public Const UI_DOEVENTS_EVERY As Long = 100            ' Yield to UI every N folders
Public Const PROGRESS_UPDATE_EVERY As Long = 50         ' Progress form update cadence
Public Const SHOW_PROGRESS_DURING_INDEX As Boolean = True

' ---- Start folder scope ----
' If non-empty, index ONLY under this folder.
' Example (default store relative): "Inbox\Projects\XYZ"
' Example (absolute): "Mailbox - Jane Doe\Inbox\Projects\XYZ"
Public Const START_FOLDER_PATH As String = ""
Public Const START_FOLDER_IS_ABSOLUTE As Boolean = False

' Include/exclude store names (display names), comma-separated (case-insensitive)
Public Const INCLUDE_STORE_NAMES As String = ""         ' Only used if SEARCH_ALL_STORES=False and you add stores
Public Const EXCLUDE_STORE_NAMES As String = "Public Folders,Archive"

' Exclude specific folders (by name) anywhere in the tree (case-insensitive)
Public Const EXCLUDE_FOLDER_NAMES As String = _
    "Sync Issues,Conversation History,Junk E-mail,Deleted Items,Outbox,Drafts," & _
    "RSS Feeds,Clutter,Groups,News Feed,Server Failures,Local Failures,Social Activity Notifications"

' Throttle: small sleep (ms) to reduce UI contention
Public Const THROTTLE_MS As Long = 2

#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If


' ===========================
'   FOLDER INDEX (cache)
' ===========================
Private gIndexBuilt As Boolean
Private gLastIndexTime As Date
Private gFolders As Collection           ' 1-based collection of MAPIFolder
Private gFolderNames() As String         ' lower-case names [1..gCount]
Private gFolderPaths() As String         ' lower-case computed paths [1..gCount]
Private gCount As Long

' Name sets (late-bound dictionaries)
Private gSkipFolderSet As Object         ' Scripting.Dictionary
Private gIncludeStoreSet As Object
Private gExcludeStoreSet As Object

' Progress dialog references
Private gProg As frmIndexProgress
Private gCanceled As Boolean

' Runtime override for start folder path (session only)
Private gStartFolderPathRuntime As String
Private gStartFolderIsAbsoluteRuntime As Boolean


' ===========================
'   PUBLIC QUICK SET MACROS
' ===========================
' Use the folder currently visible to set the start folder (session-only)
Public Sub SetStartFolderToCurrent()
    On Error GoTo CleanFail

    Dim f As Outlook.MAPIFolder
    Set f = Application.ActiveExplorer.CurrentFolder
    If f Is Nothing Then
        MsgBox "No active folder.", vbInformation
        Exit Sub
    End If

    ' FolderPath looks like: "\\Mailbox - Chris Rogers\Inbox\Subfolder"
    Dim fp As String
    fp = f.FolderPath
    If Len(fp) >= 2 And Left$(fp, 2) = "\\" Then
        fp = Mid$(fp, 3) ' remove the leading \\ to make "Mailbox - X\Inbox\..."
    End If

    gStartFolderPathRuntime = fp
    gStartFolderIsAbsoluteRuntime = True

    MsgBox "Start folder set to (session):" & vbCrLf & fp, vbInformation
    Exit Sub

CleanFail:
    MsgBox "Error in SetStartFolderToCurrent: " & Err.Description, vbExclamation
End Sub

' Clear runtime override (falls back to constants)
Public Sub ClearStartFolderOverride()
    gStartFolderPathRuntime = ""
    gStartFolderIsAbsoluteRuntime = False
    MsgBox "Start folder override cleared. Using module constants (if any).", vbInformation
End Sub


' ===========================
'   PROGRESS DIALOG HELPERS
' ===========================
Private Sub OpenIndexProgress(ByVal title As String)
    If Not SHOW_PROGRESS_DURING_INDEX Then Exit Sub
    On Error Resume Next
    Set gProg = New frmIndexProgress
    gProg.Init title
    gCanceled = False
End Sub

Private Sub UpdateProgress(ByVal visited As Long, ByVal currentPath As String)
    If gProg Is Nothing Then Exit Sub
    If (visited = 1) Or (visited Mod PROGRESS_UPDATE_EVERY = 0) Then
        gProg.UpdateCount visited
        gProg.UpdateStatus currentPath
    End If
    If gProg.CancelRequested Then gCanceled = True
End Sub

Private Sub CloseIndexProgress()
    On Error Resume Next
    If Not gProg Is Nothing Then Unload gProg
    Set gProg = Nothing
End Sub


' ===========================
'   INDEX BUILD / REBUILD
' ===========================
Public Sub RebuildFolderIndex()
    BuildFolderIndex True
    If gIndexBuilt Then
        MsgBox "Folder index rebuilt (" & gCount & " folders).", vbInformation
    ElseIf gCanceled Then
        MsgBox "Folder indexing canceled.", vbInformation
    End If
End Sub

Private Sub EnsureIndexReady()
    If Not gIndexBuilt Then
        BuildFolderIndex False
        Exit Sub
    End If
    If INDEX_REBUILD_MINUTES > 0 Then
        If Now - gLastIndexTime > INDEX_REBUILD_MINUTES / 1440# Then
            BuildFolderIndex False
        End If
    End If
End Sub

Private Sub BuildFolderIndex(ByVal force As Boolean)
    On Error GoTo CleanFail

    If Not force And gIndexBuilt Then
        If INDEX_REBUILD_MINUTES > 0 Then
            If Now - gLastIndexTime <= INDEX_REBUILD_MINUTES / 1440# Then Exit Sub
        Else
            Exit Sub
        End If
    End If

    ' Build name sets
    Set gSkipFolderSet = BuildNameSet(EXCLUDE_FOLDER_NAMES)
    Set gIncludeStoreSet = BuildNameSet(INCLUDE_STORE_NAMES)
    Set gExcludeStoreSet = BuildNameSet(EXCLUDE_STORE_NAMES)

    ' Start progress UI
    OpenIndexProgress "Indexing Outlook Folders..."

    ' Reset state
    Set gFolders = New Collection
    gCount = 0
    ReDim gFolderNames(1 To 1)
    ReDim gFolderPaths(1 To 1)
    gCanceled = False

    ' Try to resolve a specific start folder (runtime override first, then constants)
    Dim startFolder As Outlook.MAPIFolder
    Set startFolder = ResolveStartFolder()
    If Not startFolder Is Nothing Then
        ' Index only under this start folder
        AddFolderTreeToIndex startFolder, startFolder.Store.DisplayName, startFolder.name
        GoTo Finalize
    End If

    ' Otherwise, behave as configured (default store or all stores)
    Dim ns As Outlook.NameSpace
    Set ns = Application.Session

    If SEARCH_ALL_STORES Then
        Dim st As Outlook.Store
        For Each st In ns.Stores
            If ShouldSkipStore(st) Then GoTo NextStore
            If AddStoreToIndex(st) Then Exit For ' canceled
NextStore:
            If gCanceled Then Exit For
        Next
    Else
        Dim root As Outlook.MAPIFolder
        On Error Resume Next
        Set root = ns.DefaultStore.GetRootFolder
        On Error GoTo 0

        If root Is Nothing Then
            Set root = ns.GetDefaultFolder(olFolderInbox).parent
        End If

        If Not root Is Nothing Then
            AddFolderTreeToIndex root, root.Store.DisplayName, root.name
        End If

        ' Also include any explicitly included stores
        If Not gIncludeStoreSet Is Nothing Then
            Dim st2 As Outlook.Store
            For Each st2 In ns.Stores
                If LCase$(Trim$(st2.DisplayName)) <> LCase$(Trim$(root.Store.DisplayName)) Then
                    If gIncludeStoreSet.Exists(NormalizeKey(st2.DisplayName)) Then
                        If AddStoreToIndex(st2) Then Exit For
                        If gCanceled Then Exit For
                    End If
                End If
            Next
        End If
    End If

Finalize:
    If gCanceled Then
        gIndexBuilt = False
    Else
        gIndexBuilt = True
        gLastIndexTime = Now
    End If

    CloseIndexProgress
    Exit Sub

CleanFail:
    gIndexBuilt = False
    CloseIndexProgress
    MsgBox "Error building folder index: " & Err.Description, vbExclamation
End Sub

' Resolve the configured or runtime start folder; returns Nothing if not set/invalid
Private Function ResolveStartFolder() As Outlook.MAPIFolder
    Dim pathStr As String
    Dim isAbs As Boolean

    ' Runtime override takes precedence
    If Len(Trim$(gStartFolderPathRuntime)) > 0 Then
        pathStr = gStartFolderPathRuntime
        isAbs = gStartFolderIsAbsoluteRuntime
    ElseIf Len(Trim$(START_FOLDER_PATH)) > 0 Then
        pathStr = START_FOLDER_PATH
        isAbs = START_FOLDER_IS_ABSOLUTE
    Else
        Exit Function
    End If

    Dim f As Outlook.MAPIFolder
    If isAbs Then
        Set f = GetFolderByAbsolutePath(pathStr)
    Else
        Set f = GetFolderByDefaultStorePath(pathStr)
    End If

    If f Is Nothing Then
        MsgBox "Start folder not found: " & pathStr, vbExclamation
    End If

    Set ResolveStartFolder = f
End Function

' Get folder by "StoreName\Segment1\Segment2\..." (case-insensitive)
Private Function GetFolderByAbsolutePath(ByVal fullPath As String) As Outlook.MAPIFolder
    Dim parts() As String, i As Long
    parts = Split(fullPath, "\")
    If UBound(parts) < 0 Then Exit Function

    Dim storeName As String
    storeName = parts(0)

    Dim st As Outlook.Store
    For Each st In Application.Session.Stores
        If StrComp(Trim$(st.DisplayName), Trim$(storeName), vbTextCompare) = 0 Then
            Dim root As Outlook.MAPIFolder
            On Error Resume Next
            Set root = st.GetRootFolder
            On Error GoTo 0
            If Not root Is Nothing Then
                Dim cur As Outlook.MAPIFolder
                Set cur = root
                For i = 1 To UBound(parts)
                    If Len(parts(i)) = 0 Then GoTo NotFound
                    Set cur = GetChildByName(cur, parts(i))
                    If cur Is Nothing Then GoTo NotFound
                Next
                Set GetFolderByAbsolutePath = cur
                Exit Function
            End If
        End If
    Next
NotFound:
End Function

' Get folder by "Segment1\Segment2\..." relative to Default Store root
Private Function GetFolderByDefaultStorePath(ByVal relPath As String) As Outlook.MAPIFolder
    Dim root As Outlook.MAPIFolder
    On Error Resume Next
    Set root = Application.Session.DefaultStore.GetRootFolder
    On Error GoTo 0
    If root Is Nothing Then
        Set root = Application.Session.GetDefaultFolder(olFolderInbox).parent
        If root Is Nothing Then Exit Function
    End If

    Dim parts() As String, i As Long
    parts = Split(relPath, "\")
    Dim cur As Outlook.MAPIFolder
    Set cur = root

    For i = 0 To UBound(parts)
        If Len(parts(i)) = 0 Then GoTo NotFound
        Set cur = GetChildByName(cur, parts(i))
        If cur Is Nothing Then GoTo NotFound
    Next

    Set GetFolderByDefaultStorePath = cur
    Exit Function
NotFound:
End Function

' Case-insensitive child lookup under a folder
Private Function GetChildByName(ByVal parentFolder As Outlook.MAPIFolder, ByVal childName As String) As Outlook.MAPIFolder
    Dim f As Outlook.MAPIFolder
    For Each f In parentFolder.Folders
        If StrComp(Trim$(f.name), Trim$(childName), vbTextCompare) = 0 Then
            Set GetChildByName = f
            Exit Function
        End If
    Next
End Function

' Create a case-insensitive set from comma-separated names
Private Function BuildNameSet(ByVal csv As String) As Object
    Dim s As String, parts() As String, i As Long
    s = Trim$(csv)
    If Len(s) = 0 Then Exit Function

    Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    d.CompareMode = 1 ' TextCompare

    parts = Split(s, ",")
    For i = LBound(parts) To UBound(parts)
        Dim key As String
        key = NormalizeKey(parts(i))
        If Len(key) > 0 Then d(key) = True
    Next

    Set BuildNameSet = d
End Function

Private Function NormalizeKey(ByVal s As String) As String
    NormalizeKey = LCase$(Trim$(s))
End Function

Private Function ShouldSkipStore(ByVal st As Outlook.Store) As Boolean
    Dim nm As String
    nm = NormalizeKey(st.DisplayName)
    If Not gExcludeStoreSet Is Nothing Then
        If gExcludeStoreSet.Exists(nm) Then
            ShouldSkipStore = True
            Exit Function
        End If
    End If
    ShouldSkipStore = False
End Function


' ===========================
'   STORE / TREE TRAVERSAL
' ===========================
' Returns True if canceled
Private Function AddStoreToIndex(ByVal st As Outlook.Store) As Boolean
    On Error Resume Next
    Dim root As Outlook.MAPIFolder
    Set root = st.GetRootFolder
    On Error GoTo 0

    If Not root Is Nothing Then
        AddFolderTreeToIndex root, st.DisplayName, root.name
    End If

    AddStoreToIndex = gCanceled
End Function

' Non-recursive traversal with:
' - precomputed path strings
' - skip lists
' - DoEvents + Sleep throttling
Private Sub AddFolderTreeToIndex(ByVal root As Outlook.MAPIFolder, ByVal storeDisplay As String, ByVal startPath As String)
    Dim qFolders As New Collection
    Dim qPaths As New Collection

    Dim f As Outlook.MAPIFolder
    Dim subf As Outlook.MAPIFolder
    Dim visited As Long
    Dim curPath As String

    qFolders.Add root
    qPaths.Add startPath

    Do While qFolders.count > 0
        If gCanceled Then Exit Sub

        Set f = qFolders(1)
        curPath = qPaths(1)
        qFolders.Remove 1
        qPaths.Remove 1

        If Not ShouldSkipFolder(f.name) Then
            AddToIndex f, curPath
            visited = visited + 1

            ' UI yield + light throttle
            If visited Mod UI_DOEVENTS_EVERY = 0 Then
                UpdateProgress visited, storeDisplay & "\" & curPath
                DoEvents
                If THROTTLE_MS > 0 Then Sleep THROTTLE_MS
            ElseIf visited = 1 Then
                UpdateProgress visited, storeDisplay & "\" & curPath
            End If

            ' Enqueue children
            For Each subf In f.Folders
                If Not ShouldSkipFolder(subf.name) Then
                    qFolders.Add subf
                    qPaths.Add curPath & "\" & subf.name
                End If
            Next
        End If
    Loop
End Sub

' Decide if a folder (by name) should be skipped anywhere in the tree
Private Function ShouldSkipFolder(ByVal folderName As String) As Boolean
    If gSkipFolderSet Is Nothing Then
        ShouldSkipFolder = False
        Exit Function
    End If
    Dim k As String
    k = NormalizeKey(folderName)
    ShouldSkipFolder = gSkipFolderSet.Exists(k)
End Function

' Append one folder into arrays/collection (grow arrays in chunks)
Private Sub AddToIndex(ByVal f As Outlook.MAPIFolder, ByVal computedPath As String)
    gCount = gCount + 1

    If gCount = 1 Then
        ReDim gFolderNames(1 To 64)
        ReDim gFolderPaths(1 To 64)
    ElseIf gCount > UBound(gFolderNames) Then
        ReDim Preserve gFolderNames(1 To UBound(gFolderNames) * 2)
        ReDim Preserve gFolderPaths(1 To UBound(gFolderPaths) * 2)
    End If

    gFolderNames(gCount) = LCase$(f.name)
    gFolderPaths(gCount) = LCase$(computedPath)
    gFolders.Add f
End Sub


' ===========================
'   PUBLIC MACROS
' ===========================
' 1) Search for a folder by (partial) name and jump to it (uses cached index)
Public Sub GoToFolderBySearch()
    On Error GoTo CleanFail

    Dim term As String
    term = InputBox("Enter part of the folder name to find:", "Go to Folder")
    If Len(Trim$(term)) = 0 Then Exit Sub

    Dim dest As Outlook.MAPIFolder
    Set dest = SelectFolderBySearch(term)
    If dest Is Nothing Then Exit Sub

    Set Application.ActiveExplorer.CurrentFolder = dest
    Exit Sub

CleanFail:
    MsgBox "Error in GoToFolderBySearch: " & Err.Description, vbExclamation
End Sub

' 2) Move selected email(s) to a folder chosen via a **search text box** (uses cached index)
'    If nothing matches, you can create a new folder and choose where to place it.
Public Sub MoveSelectionToSearchedFolder()
    On Error GoTo CleanFail

    Dim term As String
    term = InputBox("Enter part of the destination folder name:", "Move Selection -> Search Folder")
    If Len(Trim$(term)) = 0 Then Exit Sub

    Dim dest As Outlook.MAPIFolder
    Set dest = SelectFolderBySearch(term)

    ' If SelectFolderBySearch found nothing (or user canceled multi-choice), offer to create new
    If dest Is Nothing Then
        Set dest = PromptCreateFolder(term)
        If dest Is Nothing Then Exit Sub
    End If

    Dim sel As Outlook.Selection
    Set sel = Application.ActiveExplorer.Selection

    If sel Is Nothing Or sel.count = 0 Then
        MsgBox "No items selected.", vbInformation
        Exit Sub
    End If

    Dim i As Long
    For i = 1 To sel.count
        If TypeOf sel(i) Is Outlook.MailItem Then
            Dim mi As Outlook.MailItem
            Set mi = sel(i)
            mi.Move dest
        End If
    Next i

    Exit Sub

CleanFail:
    MsgBox "Error in MoveSelectionToSearchedFolder: " & Err.Description, vbExclamation
End Sub

' 3) Enumerate sender domains for ALL emails in Inbox and stamp into a "Domain" field (user-defined)
Public Sub StampDomainFieldOnInbox()
    On Error GoTo CleanFail

    Dim inbox As Outlook.MAPIFolder
    Set inbox = Application.Session.GetDefaultFolder(olFolderInbox)

    Dim itms As Outlook.Items
    Set itms = inbox.Items

    Dim i As Long
    For i = 1 To itms.count
        Dim obj As Object
        Set obj = itms(i)
        If TypeOf obj Is Outlook.MailItem Then
            Dim mi As Outlook.MailItem
            Set mi = obj

            Dim smtp As String
            Dim dom As String

            smtp = GetSMTPAddress(mi)
            dom = GetDomainFromAddress(smtp)

            If Len(dom) > 0 Then
                Dim up As Outlook.UserProperty
                Set up = mi.UserProperties.Find(DOMAIN_FIELD_NAME)
                If up Is Nothing Then
                    Set up = mi.UserProperties.Add(DOMAIN_FIELD_NAME, olText, True)
                End If
                up.Value = dom
                mi.Save
            End If
        End If

        If i Mod (UI_DOEVENTS_EVERY * 5) = 0 Then
            DoEvents
            If THROTTLE_MS > 0 Then Sleep THROTTLE_MS
        End If
    Next i

    MsgBox "Domain field stamped for Inbox mail.", vbInformation
    Exit Sub

CleanFail:
    MsgBox "Error in StampDomainFieldOnInbox: " & Err.Description, vbExclamation
End Sub

' 4) Auto-move (prompts enabled). Shows in Macro dialog.
Public Sub AutoMoveBySenderToNameFolder()
    AutoMoveBySenderToNameFolderCore True
End Sub

' 5) DRY-RUN: Report what would move and what has no match (no changes made)
Public Sub AutoMoveBySenderToNameFolder_DryRun()
    On Error GoTo CleanFail

    Dim ns As Outlook.NameSpace
    Set ns = Application.Session

    Dim inbox As Outlook.MAPIFolder
    Set inbox = ns.GetDefaultFolder(olFolderInbox)

    Dim itms As Outlook.Items
    Set itms = inbox.Items

    Dim total As Long, moveCount As Long, noMatchCount As Long
    total = itms.count

    Dim report As String
    Dim i As Long
    For i = 1 To itms.count
        Dim obj As Object
        Set obj = itms(i)
        If TypeOf obj Is Outlook.MailItem Then
            Dim mi As Outlook.MailItem
            Set mi = obj

            Dim pretty As String
            pretty = NormalizeSenderName(mi.SenderName)

            Dim dest As Outlook.MAPIFolder
            Set dest = Nothing
            If Len(pretty) > 0 Then
                Set dest = FindExistingFolderByPrettyName(pretty)
            End If

            If Not dest Is Nothing Then
                report = report & "MOVE: """ & mi.Subject & """ -> " & pretty & " -> " & dest.FolderPath & vbCrLf
                moveCount = moveCount + 1
            Else
                report = report & "NO MATCH: """ & mi.Subject & """ � " & pretty & vbCrLf
                noMatchCount = noMatchCount + 1
            End If
        End If

        If i Mod (UI_DOEVENTS_EVERY * 5) = 0 Then DoEvents
    Next i

    Dim m As Outlook.MailItem
    Set m = Application.CreateItem(olMailItem)
    m.Subject = "AutoMove Dry Run Report - " & Format(Now, "yyyy-mm-dd hh:nn")
    m.Body = _
        "Total items scanned: " & total & vbCrLf & _
        "Would move: " & moveCount & vbCrLf & _
        "No match: " & noMatchCount & vbCrLf & vbCrLf & _
        report
    m.Display

    Exit Sub
CleanFail:
    MsgBox "Error in AutoMoveBySenderToNameFolder_DryRun: " & Err.Description, vbExclamation
End Sub


' ===========================
'   PRIVATE CORE (actual automove logic)
' ===========================
Private Sub AutoMoveBySenderToNameFolderCore(ByVal PromptCreateIfMissing As Boolean)
    On Error GoTo CleanFail

    Dim ns As Outlook.NameSpace
    Set ns = Application.Session

    Dim inbox As Outlook.MAPIFolder
    Set inbox = ns.GetDefaultFolder(olFolderInbox)

    Dim itms As Outlook.Items
    Set itms = inbox.Items

    Dim i As Long
    For i = itms.count To 1 Step -1
        Dim obj As Object
        Set obj = itms(i)
        If TypeOf obj Is Outlook.MailItem Then
            Dim mi As Outlook.MailItem
            Set mi = obj

            Dim prettyName As String
            prettyName = NormalizeSenderName(mi.SenderName)
            If Len(prettyName) = 0 Then GoTo NextItem

            ' Try to find an existing folder anywhere in the indexed scope
            Dim dest As Outlook.MAPIFolder
            Set dest = FindExistingFolderByPrettyName(prettyName)

            ' If not found, optionally prompt to create a new folder and choose its parent
            If dest Is Nothing And PromptCreateIfMissing Then
                Set dest = PromptCreateFolder(prettyName)
            End If

            If Not dest Is Nothing Then
                mi.Move dest
            End If
        End If

NextItem:
        If (itms.count - i) Mod UI_DOEVENTS_EVERY = 0 Then
            DoEvents
            If THROTTLE_MS > 0 Then Sleep THROTTLE_MS
        End If
    Next i

    MsgBox "Auto-move by sender complete.", vbInformation
    Exit Sub

CleanFail:
    If Err.Number <> 0 Then
        MsgBox "Error in AutoMoveBySenderToNameFolder: " & Err.Description, vbExclamation
    End If
End Sub


' ===========================
'   SEARCH USING CACHED INDEX
' ===========================
Public Function SelectFolderBySearch(ByVal term As String) As Outlook.MAPIFolder
    EnsureIndexReady
    Dim q As String
    q = LCase$(Trim$(term))
    If Len(q) = 0 Then Exit Function

    Dim matches As Collection
    Set matches = New Collection

    Dim i As Long
    For i = 1 To gCount
        If InStr(1, gFolderNames(i), q, vbTextCompare) > 0 _
           Or InStr(1, gFolderPaths(i), q, vbTextCompare) > 0 Then
            matches.Add i
        End If
    Next

    If matches.count = 0 Then
        ' Nothing found
        Exit Function
    ElseIf matches.count = 1 Then
        Set SelectFolderBySearch = gFolders(matches(1))
        Exit Function
    Else
        Dim listText As String, choice As Variant, k As Long
        listText = "Multiple matches found. Enter the number of your choice:" & vbCrLf & vbCrLf

        For k = 1 To matches.count
            Dim idx As Long
            idx = matches(k)
            listText = listText & k & ": " & gFolderPaths(idx) & vbCrLf
        Next

        choice = InputBox(listText, "Choose Folder")
        If IsNumeric(choice) Then
            k = CLng(choice)
            If k >= 1 And k <= matches.count Then
                Set SelectFolderBySearch = gFolders(matches(k))
            End If
        End If
    End If
End Function


' ===========================
'   HELPERS
' ===========================
' Find an existing folder by pretty name using the cached index.
' Tries exact folder name first, then exact last path segment.
Private Function FindExistingFolderByPrettyName(ByVal prettyName As String) As Outlook.MAPIFolder
    Dim q As String
    q = LCase$(Trim$(prettyName))
    If Len(q) = 0 Then Exit Function

    ' Ensure index is ready
    EnsureIndexReady

    Dim i As Long

    ' Pass 1: exact folder NAME match
    For i = 1 To gCount
        If gFolderNames(i) = q Then
            Set FindExistingFolderByPrettyName = gFolders(i)
            Exit Function
        End If
    Next

    ' Pass 2: exact last PATH segment match
    Dim lastSeg As String
    For i = 1 To gCount
        lastSeg = GetLastPathSegment(gFolderPaths(i))
        If lastSeg = q Then
            Set FindExistingFolderByPrettyName = gFolders(i)
            Exit Function
        End If
    Next
End Function

' Return the last segment of a lowercased path "a\b\c" -> "c"
Private Function GetLastPathSegment(ByVal lowerPath As String) As String
    Dim pos As Long, s As String
    s = Trim$(lowerPath)
    pos = InStrRev(s, "\")
    If pos > 0 Then
        GetLastPathSegment = Mid$(s, pos + 1)
    Else
        GetLastPathSegment = s
    End If
End Function

' Sanitize a folder name (remove invalid characters and extra spaces)
Private Function SanitizeFolderName(ByVal s As String) As String
    Dim t As String
    t = Trim$(s)
    t = Replace(t, "\", " ")
    t = Replace(t, "/", " ")
    t = Replace(t, ":", " ")
    t = Replace(t, "?", " ")
    t = Replace(t, "*", " ")
    t = Replace(t, """", "")
    t = Replace(t, "<", " ")
    t = Replace(t, ">", " ")
    t = Replace(t, "|", " ")
    Do While InStr(t, "  ") > 0
        t = Replace(t, "  ", " ")
    Loop
    SanitizeFolderName = Trim$(t)
End Function

' Prompt to create a new folder and pick its parent; returns created (or existing) folder, or Nothing
Private Function PromptCreateFolder(ByVal suggestedName As String) As Outlook.MAPIFolder
    Dim nameClean As String
    nameClean = SanitizeFolderName(suggestedName)
    If Len(nameClean) = 0 Then Exit Function

    Dim resp As VbMsgBoxResult
    resp = MsgBox( _
        "No existing folder found for:" & vbCrLf & "  " & nameClean & vbCrLf & vbCrLf & _
        "Create a new folder with this name?", _
        vbYesNoCancel + vbQuestion, "Create Folder?")
    If resp <> vbYes Then Exit Function

    Dim parent As Outlook.MAPIFolder
    Set parent = Application.Session.PickFolder
    If parent Is Nothing Then Exit Function

    Dim dest As Outlook.MAPIFolder
    On Error Resume Next
    Set dest = parent.Folders(nameClean) ' already exists?
    On Error GoTo 0

    If dest Is Nothing Then
        On Error Resume Next
        Set dest = parent.Folders.Add(nameClean)
        On Error GoTo 0
    End If

    If Not dest Is Nothing Then
        ' Add to cached index so subsequent lookups see it immediately
        IndexFolderIfNew dest
    End If

    Set PromptCreateFolder = dest
End Function

' Incrementally add a folder to the cached index (if index exists)
Private Sub IndexFolderIfNew(ByVal f As Outlook.MAPIFolder)
    On Error Resume Next
    If Not gIndexBuilt Then Exit Sub
    If gFolders Is Nothing Then Exit Sub

    ' Check if already tracked
    Dim i As Long
    For i = 1 To gCount
        If gFolders(i).EntryID = f.EntryID Then Exit Sub
    Next

    Dim fp As String, pathLower As String
    fp = f.FolderPath
    If Left$(fp, 2) = "\\" Then fp = Mid$(fp, 3)
    pathLower = LCase$(fp)

    ' Ensure arrays are sized
    If gCount = 0 Then
        ReDim gFolderNames(1 To 64)
        ReDim gFolderPaths(1 To 64)
    ElseIf gCount >= UBound(gFolderNames) Then
        ReDim Preserve gFolderNames(1 To UBound(gFolderNames) * 2)
        ReDim Preserve gFolderPaths(1 To UBound(gFolderPaths) * 2)
    End If

    gCount = gCount + 1
    gFolderNames(gCount) = LCase$(f.name)
    gFolderPaths(gCount) = pathLower
    gFolders.Add f
End Sub

' Ensure subfolder exists or create it (kept for other uses; not used by automove anymore)
Public Function EnsureSubfolder(ByVal parentFolder As Outlook.MAPIFolder, ByVal name As String, ByVal createIfMissing As Boolean) As Outlook.MAPIFolder
    On Error Resume Next
    Set EnsureSubfolder = parentFolder.Folders(name)
    On Error GoTo 0

    If EnsureSubfolder Is Nothing And createIfMissing Then
        On Error Resume Next
        Set EnsureSubfolder = parentFolder.Folders.Add(name)
        On Error GoTo 0
    End If
End Function

' Normalize "Last, First [M]" -> "First Last"; otherwise returns a cleaned name
Public Function NormalizeSenderName(ByVal senderDisplayName As String) As String
    Dim s As String
    s = Trim$(senderDisplayName)

    If Len(s) = 0 Then
        NormalizeSenderName = ""
        Exit Function
    End If

    Dim commaPos As Long
    commaPos = InStr(1, s, ",")
    If commaPos > 0 Then
        Dim lastName As String, rightSide As String, firstName As String
        lastName = Trim$(Left$(s, commaPos - 1))
        rightSide = Trim$(Mid$(s, commaPos + 1))

        Dim parts() As String
        parts = Split(RemoveExtraPunctuation(rightSide), " ")

        If UBound(parts) >= 0 Then
            firstName = parts(0)
        End If

        If Len(firstName) > 0 And Len(lastName) > 0 Then
            NormalizeSenderName = firstName & " " & lastName
        Else
            NormalizeSenderName = Trim$(RemoveExtraPunctuation(s))
        End If
    Else
        NormalizeSenderName = Trim$(RemoveExtraPunctuation(s))
    End If
End Function

' -------- Domain & parsing helpers (no Excel reference) --------
Private Function CollapseSpaces(ByVal s As String) As String
    Dim t As String
    t = Trim$(s)
    Do While InStr(t, "  ") > 0
        t = Replace(t, "  ", " ")
    Loop
    CollapseSpaces = t
End Function

Private Function RemoveExtraPunctuation(ByVal s As String) As String
    Dim t As String
    t = s
    t = Replace(t, """", "")
    t = Replace(t, "'", "")
    t = Replace(t, ".", "")
    t = CollapseSpaces(t)
    RemoveExtraPunctuation = Trim$(t)
End Function

Private Function GetSMTPAddress(ByVal mi As Outlook.MailItem) As String
    On Error GoTo Fallback

    Dim smtp As String
    smtp = ""

    If mi.SenderEmailType = "EX" Then
        If Not mi.Sender Is Nothing Then
            If Not mi.Sender.GetExchangeUser Is Nothing Then
                smtp = mi.Sender.GetExchangeUser.PrimarySmtpAddress
            ElseIf Not mi.Sender.GetExchangeDistributionList Is Nothing Then
                smtp = mi.Sender.GetExchangeDistributionList.PrimarySmtpAddress
            End If
        End If
    Else
        smtp = mi.SenderEmailAddress
    End If

    If Len(Trim$(smtp)) > 0 Then
        GetSMTPAddress = smtp
        Exit Function
    End If

Fallback:
    On Error Resume Next
    Dim pa As Outlook.PropertyAccessor
    Dim prop As String

    Set pa = mi.PropertyAccessor
    prop = "http://schemas.microsoft.com/mapi/proptag/0x5D01001E"
    smtp = pa.GetProperty(prop)
    If Len(Trim$(smtp)) = 0 Then
        prop = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
        smtp = pa.GetProperty(prop)
    End If
    On Error GoTo 0

    GetSMTPAddress = smtp
End Function

Private Function GetDomainFromAddress(ByVal addr As String) As String
    Dim a As String
    a = Trim$(addr)

    If Len(a) = 0 Then
        GetDomainFromAddress = ""
        Exit Function
    End If

    If Left$(a, 1) = "<" And Right$(a, 1) = ">" Then
        a = Mid$(a, 2, Len(a) - 2)
    End If

    Dim atPos As Long
    atPos = InStrRev(a, "@")
    If atPos > 0 And atPos < Len(a) Then
        GetDomainFromAddress = LCase$(Mid$(a, atPos + 1))
    Else
        GetDomainFromAddress = ""
    End If
End Function

' --- small string helper ---
Private Function GetFirstSegment(ByVal p As String) As String
    Dim pos As Long
    pos = InStr(1, p, "\")
    If pos > 0 Then
        GetFirstSegment = Left$(p, pos - 1)
    Else
        GetFirstSegment = p
    End If
End Function

Sub SaveSelectedAttachments()
    On Error GoTo CleanFail

    Dim oSel         As Outlook.Selection
    Dim oShell       As Object
    Dim oFolder      As Object
    Dim sFolder      As String
    Dim sTemp        As String
    Dim oAtt         As Outlook.Attachment
    Dim oMsgItem     As Object
    Dim oCount       As Object
    Dim oIndex       As Object
    Dim aTempPaths() As String
    Dim aSenders()   As String
    Dim aDates()     As Date
    Dim nItems       As Long
    Dim idx          As Long
    Dim i            As Long
    Dim j            As Long
    Dim sSender      As String
    Dim sTempPath    As String
    Dim sName        As String
    Dim sPath        As String
    Dim nSaved       As Long
    Dim swapStr      As String
    Dim swapDate     As Date

    Set oSel = Application.ActiveExplorer.Selection
    If oSel.count = 0 Then
        MsgBox "Select one or more emails first.", vbInformation
        Exit Sub
    End If

    ' Count mail items with attachments
    nItems = 0
    For i = 1 To oSel.count
        If TypeOf oSel(i) Is Outlook.MailItem Then
            If oSel(i).Attachments.count > 0 Then nItems = nItems + 1
        End If
    Next i
    If nItems = 0 Then
        MsgBox "No attachments found in selection.", vbInformation
        Exit Sub
    End If

    ReDim aTempPaths(nItems - 1)
    ReDim aSenders(nItems - 1)
    ReDim aDates(nItems - 1)

    sTemp = Environ("TEMP")

    ' Pass 1: save each attachment to temp, open inner MSG to read sender + date
    idx = 0
    For i = 1 To oSel.count
        DoEvents
        If TypeOf oSel(i) Is Outlook.MailItem Then
            If oSel(i).Attachments.count > 0 Then
                Set oAtt = oSel(i).Attachments(1)
                sTempPath = sTemp & "\dlp_temp_" & idx & ".msg"
                oAtt.SaveAsFile sTempPath

                Set oMsgItem = Application.Session.OpenSharedItem(sTempPath)
                aSenders(idx) = SanitizeName(oMsgItem.SenderName)
                aDates(idx) = oMsgItem.SentOn
                oMsgItem.Close olDiscard
                Set oMsgItem = Nothing

                aTempPaths(idx) = sTempPath
                idx = idx + 1
            End If
        End If
    Next i

    ' Sort by sent date ascending (bubble sort)
    For i = 0 To nItems - 2
        For j = 0 To nItems - 2 - i
            If aDates(j) > aDates(j + 1) Then
                swapStr = aTempPaths(j): aTempPaths(j) = aTempPaths(j + 1): aTempPaths(j + 1) = swapStr
                swapStr = aSenders(j): aSenders(j) = aSenders(j + 1): aSenders(j + 1) = swapStr
                swapDate = aDates(j): aDates(j) = aDates(j + 1): aDates(j + 1) = swapDate
            End If
        Next j
    Next i

    ' Count occurrences per sender
    Set oCount = CreateObject("Scripting.Dictionary")
    oCount.CompareMode = 1
    For i = 0 To nItems - 1
        If Not oCount.Exists(aSenders(i)) Then oCount(aSenders(i)) = 0
        oCount(aSenders(i)) = oCount(aSenders(i)) + 1
    Next i

    ' Folder picker
    Set oShell = CreateObject("Shell.Application")
    Set oFolder = oShell.BrowseForFolder(0, "Save Attachments To...", 0)
    If oFolder Is Nothing Then
        For i = 0 To nItems - 1
            If Dir(aTempPaths(i)) <> "" Then Kill aTempPaths(i)
        Next i
        Exit Sub
    End If
    sFolder = oFolder.Self.Path

    ' Pass 2: move temp files to final destination with new names
    Set oIndex = CreateObject("Scripting.Dictionary")
    oIndex.CompareMode = 1  ' case-insensitive, consistent with oCount

    For i = 0 To nItems - 1
        DoEvents
        sSender = aSenders(i)
        If Not oIndex.Exists(sSender) Then oIndex(sSender) = 0
        oIndex(sSender) = oIndex(sSender) + 1

        If oCount(sSender) = 1 Then
            sName = "Individual Incident - " & sSender & " - " & Format(aDates(i), "yyyy-mm-dd") & ".msg"
        Else
            sName = "Individual Incident - " & sSender & " (" & oIndex(sSender) & ") - " & Format(aDates(i), "yyyy-mm-dd") & ".msg"
        End If

        sPath = sFolder & "\" & sName
        FileCopy aTempPaths(i), sPath
        Kill aTempPaths(i)
        nSaved = nSaved + 1
    Next i

    MsgBox nSaved & " file(s) saved.", vbInformation
    Exit Sub

CleanFail:
    ' Clean up any temp files that were written before the failure
    If Not IsEmpty(aTempPaths) Then
        For i = 0 To UBound(aTempPaths)
            If Len(aTempPaths(i)) > 0 Then
                If Dir(aTempPaths(i)) <> "" Then Kill aTempPaths(i)
            End If
        Next i
    End If
    If Not oMsgItem Is Nothing Then On Error Resume Next: oMsgItem.Close olDiscard: On Error GoTo 0
    MsgBox "Error in SaveSelectedAttachments: " & Err.Description, vbExclamation
End Sub

Function SanitizeName(s As String) As String
    Dim result As String
    result = s
    result = Replace(result, "\", "")
    result = Replace(result, "/", "")
    result = Replace(result, ":", "")
    result = Replace(result, "*", "")
    result = Replace(result, "?", "")
    result = Replace(result, """", "")
    result = Replace(result, "<", "")
    result = Replace(result, ">", "")
    result = Replace(result, "|", "")
    SanitizeName = Trim(result)
End Function