troubleshooting Question

Move Mails from Set according to the Folder names in the sent.

Avatar of bsharath
bsharathFlag for India asked on
Microsoft OfficeOutlookMicrosoft Applications
49 Comments1 Solution328 ViewsLast Modified:
Hi,

Move Mails from Set according to the Folder names in the sent.
I have say 20,000 + mails in the set folder. And 400+ folders with the exact names of users. When run i want each mail to be moved from sent to these folders if name matched. If no match then create a folder with the users name and move them. Just local Domain users only need to be created and moved.

I may have mails that i sent to external users. Those have to stay intact in the sent box.

I have the folder names with the exact names of the users.

Below is the code that does the same for inbox. I want the code to be adjusted according to the above .If no folder present create and move. if present just move only internal mails.

Regards
Sharath
Private olkTargetFolder As Outlook.Folder
 
Sub MoveTen()
    'Change the folder path on the next two lines'
    Const ROOT1 = "All Mails\Inbox"
    Const ROOT2 = "Latest Mails\Inbox"
    'Change the number on the next line to that of the number of items required to trigger a move'
    Const MAXITEMS = 10
    Dim olkItems As Outlook.Items, _
        olkItem As Object, _
        olkRoot As Outlook.Folder, _
        objDict As Object, _
        arrNames As Variant, _
        arrNamePos As Variant, _
        varName As Variant, _
        intIndex As Integer
    Set objDict = CreateObject("Scripting.Dictionary")
    Set olkItems = Application.ActiveExplorer.CurrentFolder.Items
    olkItems.Sort "[SenderName]"
    For Each olkItem In olkItems
        If Not objDict.Exists(olkItem.SenderName) Then
            objDict.Add olkItem.SenderName, olkItem.SenderName
        End If
    Next
    arrNames = objDict.Items()
    For Each varName In arrNames
        Set olkItems = Application.ActiveExplorer.CurrentFolder.Items.Restrict("[SenderName] = '" & Replace(varName, "'", "''") & "'")
        If olkItems.Count >= MAXITEMS Then
            arrNamePos = Split(varName, " ")
            Select Case UBound(arrNamePos)
                Case 0  'SenderName was a single value'
                    strName = arrNamePos(0)
                Case 1  'SenderName was two values, presumeably last and first name'
                    strName = Replace(arrNamePos(0) & " " & arrNamePos(1), ",", "")
                Case 2  'SenderName was three values, presumeably last, first, and middle name'
                    strName = Replace(arrNamePos(0) & " " & arrNamePos(1), ",", "")
                Case Else
                    strName = ""
            End Select
            Debug.Print varName & " = " & strName
            Set olkRoot = OpenOutlookFolder(ROOT1)
            Set olkTargetFolder = Nothing
            FindMatchingFolder olkRoot, strName
            If TypeName(olkTargetFolder) = "Nothing" Then
                Set olkRoot = OpenOutlookFolder(ROOT2)
                FindMatchingFolder olkRoot, strName
            End If
            If TypeName(olkTargetFolder) <> "Nothing" Then
                For intIndex = olkItems.Count To 1 Step -1
                    Set olkItem = olkItems.Item(intIndex)
                    olkItem.Move olkTargetFolder
                Next
            End If
        End If
    Next
    Set olkItems = Nothing
    Set olkItem = Nothing
    Set olkTargetFolder = Nothing
    Set objDict = Nothing
    MsgBox "Finished"
End Sub
 
Sub FindMatchingFolder(olkFolder As Outlook.Folder, ByVal strName As String)
    Dim olkSubFolder As Outlook.Folder
    If olkFolder.Name = strName Then
        Set olkTargetFolder = olkFolder
    Else
        For Each olkSubFolder In olkFolder.Folders
            FindMatchingFolder olkSubFolder, strName
        Next
    End If
    Set olkSubFolder = Nothing
End Sub
Join the community to see this answer!
Join our exclusive community to see this answer & millions of others.
Unlock 1 Answer and 49 Comments.
Join the Community
Learn from the best

Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.

Andrew Hancock - VMware vExpert
See if this solution works for you by signing up for a 7 day free trial.
Unlock 1 Answer and 49 Comments.
Try for 7 days

”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.

-Mike Kapnisakis, Warner Bros