All geek questions in one place

Move mail from sender to sender folder name

I want to move messages from the sender to a folder created for the sender.

The sender name is displayed as "Doe, John (US)" and my folder will be "Doe, John".

What do I need to do to compare SenderName with the name of the subfolder, which is two levels below "Inbox". Ie Inbox→Folder1→"Doe, John". "Inbox". Ie Inbox→Folder1→"Doe, John".

 Public Sub MoveToFolder() Dim objOutlook As Outlook.Application Dim objNameSpace As Outlook.NameSpace Dim objDestFolder As Outlook.MAPIFolder Dim objSourceFolder As Outlook.Folder Dim currentExplorer As Explorer Dim Selection As Selection Dim obj As Object Dim objSubfolder As Outlook.Folder Dim olsubFolder As Outlook.Folder Dim olApp As Outlook.Application Dim objNS As Outlook.NameSpace Dim olFolder As Outlook.MAPIFolder Dim Msg As Outlook.MailItem Dim objVariant As Variant Dim lngMovedItems As Long Dim intCount As Integer Set objOutlook = Application Set objNameSpace = objOutlook.GetNamespace("MAPI") Set currentExplorer = objOutlook.ActiveExplorer Set Selection = currentExplorer.Selection Set objSourceFolder = currentExplorer.CurrentFolder Set olApp = Outlook.Application Set objNS = olApp.GetNamespace("MAPI") Set olFolder = objNS.GetDefaultFolder(olFolderInbox) Set olFolder = olFolder.Folders("Inbox") Set colFolders = objParentFolder.Folders For Each obj In Selection Set objVariant = obj Dim sfName As Object Set sfName = Left(objVariant.senderName, Len(objVariant.senderName) - 5) If objVariant.Class = olMail Then On Error Resume Next ' Use These lines if the destination folder ' is not a subfolder of the current folder For Each objSubfolder In colFolders For Each olsubFolder In objSubfolder If olsubFolder.Name = sfName Then Set objDestFolder = objSubfolder MsgBox "Ductus Exemplo" 'objVariant.Move objDestFolder 'count the # of items moved lngMovedItems = lngMovedItems + 1 'Display the number of items that were moved. MsgBox "Moved " & lngMovedItems & " messages(s) from " & _ sfName & "to " & objDestFolder Else If objDestFolder Is Nothing Then MsgBox "No Folder Found for " & sfName 'Set objDestFolder = objSourceFolder.Folders.Add(sfName) Exit Sub End If Next Next Next End If End Sub
+5
source share
3 answers

Assumptions

  • The subfolders of the senders will be two levels below the inbox, but not under the same parent folder (that is, "Doe, John" may appear under Folder1 and "Doe, Jane" in Folder2)
  • All emails to be processed by the macro will be selected before it is executed.
  • The code should not create subfolders for missing senders - since there are several possible “parent” folders, but it should display a message containing a list of missing sender folders.

Conditions that cause the end of the sender name:

  • A hyphen followed by or preceding a space (i.e., "Dow, John - USA" = "Dow, John" and "Huntington-Whiteley, Rosie - CAN" = Huntington-Whiteley, Rosie ")
  • Second instance of a comma (i.e., "Doe, John, CPA" = "Doe, John")
  • The second instance of space (i.e., "Doe, John Q" = "Doe, John")
  • An apostrophe that was preceded or accompanied by space (i.e., “O'Leary, John” = “O'Leary, John,” but “Dow, John” USA = “Dow, John”)
  • Any other alphabetic character (i.e., "Doe, John: US" = "Doe, John"

Proposed solution

This code will satisfy all the above conditions and at the end will display one message indicating any senders for which folders cannot be found (as opposed to a separate message for each letter). It has been tested in Outlook 2013 / Windows 10.

 Public Sub MoveToFolder() Dim objSelection As Selection Set objSelection = Application.ActiveExplorer.Selection Dim iSelected As Integer, iMoved As Integer iSelected = objSelection.Count 'Get a total for output message Dim StrOutput As String, StrUnmoved As String, StrName As String StrUnmoved = "Unmoved Item Count by Sender" & vbNewLine & "============================" Dim objNS As NameSpace Dim objParentFolder As Folder, objSubFolder As Folder, objDestFolder As Folder Dim BFound As Boolean, iLoc As Integer Set objNS = Application.GetNamespace("MAPI") Set objParentFolder = objNS.GetDefaultFolder(olFolderInbox) 'Only execute code if the parent folder has subfolders If objParentFolder.Folders.Count > 0 Then 'Loop through all selected items For Each Item In objSelection If Item.Class = 43 Then 'This is an email. BFound = False StrName = GetSenderName(Item.SenderName) For Each objSubFolder In objParentFolder.Folders If objSubFolder.Folders.Count > 0 Then On Error Resume Next Set objDestFolder = Nothing Set objDestFolder = objSubFolder.Folders(StrName) On Error GoTo 0 If Not objDestFolder Is Nothing Then 'Folder found. Item.Move objDestFolder iMoved = iMoved + 1 BFound = True Exit For End If End If Next If Not BFound Then 'Sender folder not found. Check if we have already logged this sender. iLoc = 0 iLoc = InStr(1, StrUnmoved, StrName) If iLoc > 0 Then 'Existing sender name. Increment current total. StrUnmoved = Left(StrUnmoved, iLoc + Len(StrName) + 1) & _ Format(CInt(Mid(StrUnmoved, iLoc + Len(StrName) + 2, 5)) + 1, "00000") & Right(StrUnmoved, Len(StrUnmoved) - iLoc - Len(StrName) - 6) Else 'New sender name. StrUnmoved = StrUnmoved & vbNewLine & StrName & ": 00001" End If End If End If Next If iMoved = iSelected Then StrOutput = "All " & iSelected & " items moved to appropriate subfolders." Else 'Remove extraneous zeroes StrUnmoved = Replace(StrUnmoved, ": 000", ": ") StrUnmoved = Replace(StrUnmoved, ": 00", ": ") StrUnmoved = Replace(StrUnmoved, ": 0", ": ") StrOutput = iMoved & "/" & iSelected & " items moved to appropriate subfolders; see below for unmoved details." & vbNewLine & vbNewLine & StrUnmoved End If MsgBox StrOutput Else MsgBox "There are no subfolders to the default inbox. Script will now exit." End If End Sub Function GetSenderName(StrFullSender As String) As String 'Only take action if a non-null string is passed If Len(StrFullSender) > 1 Then StrFullSender = Trim(StrFullSender) 'Trim extraneous spaces Dim StrOutput As String 'Find first case of the end of the name Dim iChar As Integer Dim iCommaCount As Integer Dim iSpaceCount As Integer For iChar = 1 To Len(StrFullSender) Select Case Asc(Mid(StrFullSender, iChar, 1)) Case 65 To 90, 97 To 122 '192 to 246, 248 to 255 'Include 192-246 and 248-255 if you will receive emails from senders with accents or other symbols in their names 'No action necessary - this is a letter Case 45, 151 'Hyphen or EM Dash - could be a hyphenated name If Mid(StrFullSender, IIf(iChar = 1, 1, iChar - 1), IIf(Len(StrFullSender) - iChar > 1, 3, Len(StrFullSender) - iChar + 1)) <> _ Trim(Mid(StrFullSender, IIf(iChar = 1, 1, iChar - 1), IIf(Len(StrFullSender) - iChar > 1, 3, Len(StrFullSender) - iChar + 1))) Then Exit For 'There is a space on one or both sides of the hyphen. This is a valid stop. Case 44 iCommaCount = iCommaCount + 1 If iCommaCount > 1 Then Exit For Case 32 iSpaceCount = iSpaceCount + 1 If iSpaceCount > 1 Then Exit For Case 39 If Mid(StrFullSender, IIf(iChar = 1, 1, iChar - 1), IIf(Len(StrFullSender) - iChar > 1, 3, Len(StrFullSender) - iChar + 1)) <> _ Trim(Mid(StrFullSender, IIf(iChar = 1, 1, iChar - 1), IIf(Len(StrFullSender) - iChar > 1, 3, Len(StrFullSender) - iChar + 1))) Then Exit For 'There is a space on one or both sides of the apostrophe. This is a valid stop. Case Else Exit For End Select Next StrOutput = Trim(Left(StrFullSender, iChar - 1)) GetSenderName = StrOutput End If End Function
+2
source

The goal is to create selected mail items based on the name of the sender in the call.

Put a little further, as you can move items within the selected folder when nothing has been moved (i.e. only selected meeting items).

When you select a folder to process items, the folder cannot be the main subfolder or child folders.

 Option Explicit Private Const SUB_FDR As String = "Folder1" ' The name of main sub-folder under Inbox to move mails to Sub MoveSenderToFolder() Dim oNS As NameSpace, oMainFDR As Folder, oSubFDR As Folder Dim oItem As Variant, iMoved As Long On Error Resume Next Set oNS = Application.GetNamespace("MAPI") On Error GoTo 0 If oNS Is Nothing Then MsgBox "Cannot get MAPI namespace from Outlook! Abortting!", vbCritical + vbOKOnly, "MoveSenderToFolder()" Else ' Proceed to Set Folders Set oMainFDR = oNS.GetDefaultFolder(olFolderInbox) ' Get the sub folder "SUB_FDR" under Inbox If Not oMainFDR Is Nothing Then Set oSubFDR = GetSubFolder(oMainFDR, SUB_FDR) If oSubFDR Is Nothing Then MsgBox "Cannot get the main sub folder """ & SUB_FDR & """ under """ & oMainFDR.Name & """" Else iMoved = 0 ' [1] Process the Selected items For Each oItem In ActiveExplorer.Selection MoveItemToFolder oItem, oSubFDR, iMoved Next ' [2] Ask to process a Folder if no MailItems are moved from Selection If iMoved = 0 Then If vbYes = MsgBox("Would you like to select a folder to move mail items?", vbQuestion + vbYesNo, "MoveSenderToFolder()") Then Set oMainFDR = oNS.PickFolder ' Reuse oMainFDR object to the selected folder ' Only proceed if it a folder not within Main Sub folder. If Len(Replace(oMainFDR.FolderPath, oSubFDR.FolderPath, "")) = Len(oMainFDR.FolderPath) Then For Each oItem In oMainFDR.Items MoveItemToFolder oItem, oSubFDR, iMoved Next Else MsgBox "Will not process folder/subfolders of the main folder """ & SUB_FDR & """", vbInformation + vbOKOnly, "MoveSenderToFolder()" End If End If End If Set oSubFDR = Nothing Set oMainFDR = Nothing End If Set oNS = Nothing MsgBox iMoved & " item(s) are moved.", vbInformation + vbOKOnly, "MoveSenderToFolder()" End If End Sub ' Move input item to a sub folder and increment counter Private Sub MoveItemToFolder(ByRef oItem As Variant, ByRef oSubFDR As Folder, ByRef iMoved As Long) Dim oMail As MailItem, sName As String, oTargetFDR As Folder If TypeName(oItem) = "MailItem" Then Set oMail = oItem sName = GetSenderName(oMail) Set oTargetFDR = GetSubFolder(oSubFDR, sName) If oTargetFDR Is Nothing Then MsgBox "Cannot get Target folder """ & oSubFDR.FolderPath & "\" & sName & """" Else oMail.Move oTargetFDR iMoved = iMoved + 1 End If Set oMail = Nothing End If End Sub ' Extract the Sender Name before any brackets Private Function GetSenderName(ByRef oItem As MailItem) As String Dim sName As String sName = oItem.SenderName If InStr(1, sName, "(", vbTextCompare) > 1 Then sName = Split(sName, "(")(0) If InStr(1, sName, "<", vbTextCompare) > 1 Then sName = Split(sName, "<")(0) If InStr(1, sName, "[", vbTextCompare) > 1 Then sName = Split(sName, "[")(0) If InStr(1, sName, "{", vbTextCompare) > 1 Then sName = Split(sName, "{")(0) GetSenderName = Trim(sName) End Function ' Given a name, get the sub-folder object from a main folder (create if required) Private Function GetSubFolder(ByRef oParentFDR As Folder, ByVal sName As String) As Folder On Error Resume Next Dim oFDR As Folder Set oFDR = oParentFDR.Folders(sName) If oFDR Is Nothing Then Set oFDR = oParentFDR.Folders.Add(sName) Set GetSubFolder = oFDR End Function

CODE UPDATE based on OP comment

Searches for all auxiliary folders in the inbox for the sender name. If not found, a request to create from the Binder folder will appear.

 Option Explicit Private oNS As NameSpace Sub MoveSenderToFolder() Dim oMainFDR As Folder, oSubFDR As Folder Dim oItem As Variant, iMoved As Long On Error Resume Next Set oNS = Application.GetNamespace("MAPI") On Error GoTo 0 If oNS Is Nothing Then MsgBox "Cannot get MAPI namespace from Outlook! Abortting!", vbCritical + vbOKOnly, "MoveSenderToFolder()" Else ' Proceed to Set Folders Set oMainFDR = oNS.GetDefaultFolder(olFolderInbox) If Not oMainFDR Is Nothing Then iMoved = 0 ' [1] Process the Selected items For Each oItem In ActiveExplorer.Selection MoveItemToFolder oItem, oMainFDR, iMoved Next ' [2] Ask to process a Folder if no MailItems are moved from Selection If iMoved = 0 Then If vbYes = MsgBox("Would you like to select a folder to move mail items?", vbQuestion + vbYesNo, "MoveSenderToFolder()") Then Set oSubFDR = oNS.PickFolder ' Reuse oMainFDR object to the selected folder For Each oItem In oSubFDR.Items MoveItemToFolder oItem, oMainFDR, iMoved Next Set oSubFDR = Nothing End If End If Set oSubFDR = Nothing Set oMainFDR = Nothing End If Set oNS = Nothing MsgBox iMoved & " item(s) are moved.", vbInformation + vbOKOnly, "MoveSenderToFolder()" End If End Sub ' Get Folder object based on a Name and a root folder Private Function GetSenderFolder(ByRef oRootFDR As Folder, ByVal sName As String) As Folder Dim oFDR As Folder, oFDR2 As Folder For Each oFDR In oRootFDR.Folders If oFDR.Name = sName Then Set oFDR2 = oFDR Exit For End If Next If oFDR Is Nothing Then For Each oFDR In oRootFDR.Folders Set oFDR2 = GetSenderFolder(oFDR, sName) If Not oFDR2 Is Nothing Then Exit For Next End If Set GetSenderFolder = oFDR2 End Function ' Move input item (Mail Items only) to a sub folder and increment counter Private Sub MoveItemToFolder(ByRef oItem As Variant, ByRef oRootFDR As Folder, ByRef iMoved As Long) Dim oMail As MailItem, sName As String, oTargetFDR As Folder If TypeName(oItem) = "MailItem" Then Set oMail = oItem sName = GetSenderName(oMail) Set oTargetFDR = GetSenderFolder(oRootFDR, sName) If oTargetFDR Is Nothing Then If vbYes = MsgBox("Cannot get Target folder """ & oRootFDR.FolderPath & "\" & sName & """" & vbLf & _ "Would you like to create the folder from folder of your choice?", vbQuestion + vbYesNo) Then Set oTargetFDR = CreateSubFolder(sName) End If End If If Not oTargetFDR Is Nothing Then oMail.Move oTargetFDR iMoved = iMoved + 1 End If Set oMail = Nothing End If End Sub ' Extract the Sender Name before any brackets Private Function GetSenderName(ByRef oItem As MailItem) As String Dim sName As String sName = oItem.SenderName If InStr(1, sName, "(", vbTextCompare) > 1 Then sName = Split(sName, "(")(0) If InStr(1, sName, "<", vbTextCompare) > 1 Then sName = Split(sName, "<")(0) If InStr(1, sName, "[", vbTextCompare) > 1 Then sName = Split(sName, "[")(0) If InStr(1, sName, "{", vbTextCompare) > 1 Then sName = Split(sName, "{")(0) GetSenderName = Trim(sName) End Function ' Given a name, Create the sub-folder object from Folder Picker Private Function CreateSubFolder(ByVal sName As String) As Folder On Error Resume Next Dim oFDR As Folder Set oFDR = oNS.PickFolder If Not oFDR Is Nothing Then Set oFDR = oFDR.Folders.Add(sName) Set CreateSubFolder = oFDR End Function
+2
source

Update Folders("Folder1") Folder Name Folders("Folder1")

 Option Explicit Sub File_olItems() Dim olNameSpace As Outlook.NameSpace Dim olSourceFolder As Outlook.Folder Dim olDestFolder As Outlook.Folder Dim currentExplorer As Explorer Dim Selection As Selection Dim olItem As MailItem Dim vItem As Variant Dim NameSender As String Dim i As Long Set olNameSpace = Application.GetNamespace("MAPI") Set currentExplorer = Application.ActiveExplorer Set Selection = currentExplorer.Selection Set olSourceFolder = olNameSpace.GetDefaultFolder(olFolderInbox).Folders("Folder1") For Each olItem In Selection Set vItem = olItem If vItem.Class = olMail Then Debug.Print vItem.SentOnBehalfOfName NameSender = vItem.SentOnBehalfOfName If NameSender = ";" Then NameSender = vItem.SenderName End If If InStr(1, NameSender, "(", vbTextCompare) > 1 Then NameSender = Split(NameSender, "(")(0) Debug.Print NameSender End If On Error Resume Next Set olDestFolder = olSourceFolder.Folders(NameSender) If olDestFolder Is Nothing Then Set olDestFolder = olSourceFolder.Folders.Add(NameSender) End If vItem.Move olDestFolder ' // count items moved i = i + 1 Set olDestFolder = Nothing End If Next olItem ' // Display the number of items that were moved. MsgBox "Moved " & i & " Mail Items." Set currentExplorer = Nothing Set olItem = Nothing Set Selection = Nothing Set olNameSpace = Nothing Set olSourceFolder = Nothing End Sub
0
source

Source: https://habr.com/ru/post/1236074/

More articles:


All Articles