I would like to export the count by category for multiple folders from Outlook to Excel.
I have tried to use a For...Loop, but it loops the current folders instead of looping the subfolders.
Sub CategoriesEmails()
Dim oFolder As MAPIFolder
Dim oDict As Object
Dim sStartDate As String
Dim sEndDate As String
Dim oItems As Outlook.Items
Dim sStr As String
Dim sMsg As String
Dim strFldr As String
Dim OutMail As Object
Dim xlApp As Object
On Error Resume Next
Set oFolder = Application.ActiveExplorer.CurrentFolder
Set oDict = CreateObject("Scripting.Dictionary")
sStartDate = InputBox("Type the start date (format MM/DD/YYYY)")
sEndDate = InputBox("Type the end date (format MM/DD/YYYY)")
Set oItems = oFolder.Items.Restrict("[Received] >= '" & sStartDate & "' And [Received] <= '" & sEndDate & "'")
oItems.SetColumns ("Categories")
For Each aItem In oItems
sStr = aItem.Categories
If Not oDict.Exists(sStr) Then
oDict(sStr) = 0
End If
oDict(sStr) = CLng(oDict(sStr)) + 1
Next aItem
sMsg = ""
For Each aKey In oDict.Keys
sMsg = sMsg & aKey & ": " & oDict(aKey) & vbCrLf
Next
MsgBox sMsg
strFldr = ""
Set xlApp = CreateObject("Excel.Application")
xlApp.Application.Visible = True
xlApp.Workbooks.Open strFldr & "CountByCategories.xlsx"
xlApp.Sheets("Sheet1").Select
For Each aKey In oDict.Keys
xlApp.Range("A1") = "Folder Name"
xlApp.Range("A1").Font.Bold = True
xlApp.Range("B1") = "Category"
xlApp.Range("B1").Font.Bold = True
xlApp.Range("C1") = "Count"
xlApp.Range("C1").Font.Bold = True
xlApp.Range("D1") = "Start Date"
xlApp.Range("D1").Font.Bold = True
xlApp.Range("E1") = "End Date"
xlApp.Range("E1").Font.Bold = True
xlApp.Range("A2").Offset(i, 0).Value = oFolder
xlApp.Range("B2").Offset(i, 0).Value = aKey
xlApp.Range("C2").Offset(i, 0).Value = oDict(aKey) & vbCrLf
xlApp.Range("D2").Offset(i, 0).Value = sStartDate
xlApp.Range("E2").Offset(i, 0).Value = sEndDate
i = i + 1
Next
xlApp.Save
Set oFolder = Nothing
End Sub
I could successfully export the count by category for a particular folder but fail to do so for multiple folders.
A sample code enumerates all folders on all stores for a session:
Sub EnumerateFoldersInStores()
Dim colStores As Outlook.Stores
Dim oStore As Outlook.Store
Dim oRoot As Outlook.Folder
On Error Resume Next
Set colStores = Application.Session.Stores
For Each oStore In colStores
Set oRoot = oStore.GetRootFolder
Debug.Print (oRoot.FolderPath)
EnumerateFolders oRoot
Next
End Sub
Private Sub EnumerateFolders(ByVal oFolder As Outlook.Folder)
Dim folders As Outlook.folders
Dim Folder As Outlook.Folder
Dim foldercount As Integer
On Error Resume Next
Set folders = oFolder.folders
foldercount = folders.Count
'Check if there are any folders below oFolder
If foldercount Then
For Each Folder In folders
' here you can call your function to gather all categories from a folder
' Sub CategoriesEmails(Folder)
Debug.Print (Folder.FolderPath)
EnumerateFolders Folder
Next
End If
End Sub
The code sample begins by getting all the stores for the current session using the NameSpace.Stores property of the current Application.Session.
For each store of this session, it uses Store.GetRootFolder to obtain the folder at the root of the store.
For the root folder of each store, it iteratively calls the EnumerateFolders procedure until it has visited and displayed the name of each folder in that tree.
I have a Company Project where ~500 clients send Emails to the my project inbox. Those clients correspond to ~150 offices (I have an Excel-List of the email addresses & according offices).
Each office shall have one Outlook folder, so I can quickly check upon the past correspondence with a specific office.
The Project inbox is looked after and used by several co-workers, hence server- and not client based rules.
How do I set this up?
My simple idea in form of a pseudo code:
for each arriving email
if (from-adress is in "email & office-List")
move that email to outlook folder "according office name"
end if
end for
and the same for outgoing emails:
for each sent email
if (to-adress is in "email & office-List")
move that email to outlook folder "according office name"
end if
end for
Thanks for suggestions!
...and besides, can outlook folders be created programmatically from a list of names?
My solution is a skript i run daily on a manual basis since my employer doesnt allow scripts on arriving messages.
the logic in short is:
fetch list of emails & their corresponding offices (both string lists)
set up folder variables
loop through messages, and move them eventually
the code looks like
Option Compare Text ' makes string comparisons case insensitive
Sub sortEmails()
'sorts the emails into folders
Dim msg As Outlook.MailItem
Dim itm As Object
Dim adress As String
Dim pa As Outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = _
"http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
'1) fetch emails
GetEMailsFolders locIDs, emails, n
'1.5) fetch folder objects
'Create an instance of Outlook & inbox reference
Dim Inbox As Outlook.MAPIFolder
Dim outbox As Outlook.MAPIFolder
Set outlookApp = New Outlook.Application
Set NS = outlookApp.GetNamespace("MAPI")
Set objOwner = NS.CreateRecipient("email#host.com")
objOwner.Resolve
'Set inbox = NS.GetSharedDefaultFolder(objOwner, olFolderInbox)
Set Inbox = NS.Folders("email#host.com").Folders("Inbox")
Set outbox = NS.Folders("email#host.com").Folders("Sent Items")
Dim basefolder As Outlook.MAPIFolder
Dim bfName As String
bfName = "Offices" 'name of the folder for the offices
Set basefolder = MkDirConditional(Inbox.Folders("Project folder"), bfName)
'2)loop through inbox & outbox emails
Dim destination As Outlook.MAPIFolder
Dim fold(1 To 2) As Outlook.MAPIFolder
Set fold(1) = Inbox
Set fold(2) = outbox
Dim LocID As String
For Each fol In fold 'loop through inbox & outbox
Debug.Print fol
'reverse fo loop because otherwise moved messages modify indices of following messages
For i = fol.Items.Count To 1 Step -1 'Each itm In fol.Items
Set itm = fol.Items(i)
If TypeName(itm) = "MailItem" Then ' others are AppointmentItem, MeetingItem, or TaskItem
Set msg = itm
'Debug.Print " " & msg.Subject
If fol = Inbox Then
' there are two formats of email adrersses.
If msg.SenderEmailType = "EX" Then 'check two kinds of email adress formats
adress = msg.Sender.GetExchangeUser().PrimarySmtpAddress
ElseIf msg.SenderEmailType = "SMTP" Then 'SMTP case
adress = msg.SenderEmailAddress
Else
Debug.Print " neither EX nor SMTP" & msg.Subject;
End If
pos = Findstring(adress, emails) ' position in the email / standort list
ElseIf fol = outbox Then
For Each rec In msg.Recipients
Set pa = rec.PropertyAccessor
adress = pa.GetProperty(PR_SMTP_ADDRESS)
pos = Findstring(adress, emails)
If pos > 0 Then
Exit For
End If
Next rec
End If
'4.5) if folder doesnt exist, create it
'5) move message
If pos > 0 Then
'Debug.Print " Its a Match!!"
LocID = locIDs(pos)
Set destination = MkDirConditional(basefolder, LocID)
Debug.Print " " & Left(msg.Subject, 20), adress, pos, destination
msg.Move destination
Else
'Debug.Print " not found!"
End If
Else
'Debug.Print " " & "non-mailitem", itm.Subject
End If
Next i
Next fol
End Sub
'// Function - Check folder Exist
Private Function FolderExists(Inbox As Outlook.MAPIFolder, FolderName As String) As Boolean
Dim Sub_Folder As MAPIFolder
On Error GoTo Exit_Err
Set Sub_Folder = Inbox.Folders(FolderName)
FolderExists = True
Exit Function
Exit_Err:
FolderExists = False
End Function
Function MkDirConditional(basefolder As Outlook.MAPIFolder, newfolder As String) As Outlook.MAPIFolder
Debug.Print newfolder & " ";
If FolderExists(basefolder, newfolder) Then
'folder exists, so just skip
Set MkDirConditional = basefolder.Folders(newfolder)
Debug.Print "exists already"
Else
'folder doesnt exist, make it
Set MkDirConditional = basefolder.Folders.Add(newfolder)
Debug.Print "created"
End If
End Function
'function to compare two strings, min the option compare text at the top line
Function Findstring(str As String, arr As Variant) As Integer
'returns -1 if a string is not found, otherwise its index
Findstring = -1
Dim i As Integer
i = 1
For Each Item In arr
'Debug.Print Item
If str = Item Then
Findstring = i
Exit For
End If
i = i + 1
Next
End Function
' function to fetch the lists of emails and offices
Sub GetEMailsFolders(ByRef rng1 As Variant, ByRef rng2 As Variant, ByRef n As Variant)
'declare variables
Dim xExcelFile As String
Dim xExcelApp As Excel.Application
Dim xWb As Excel.Workbook
Dim xWs As Excel.Worksheet
Dim xExcelRange As Excel.Range
Dim TotalRows As Long
'declare SPOC xls file
xExcelFile = "adresses.xlsx"
'open the file
Set xExcelApp = CreateObject("Excel.Application")
Set xWb = xExcelApp.Workbooks.Open(xExcelFile)
Set xWs = xWb.Sheets(1)
'extract LocIDs (column A), emails (column O) and thir number
n = xWs.Range(xWs.Range("A2"), xWs.Range("A2").End(xlDown)).Count ' works
ReDim rng1(1 To n) As Variant
ReDim rng2(1 To n) As Variant
For i = 1 To n
rng1(i) = xWs.Cells(i + 1, 1)
rng2(i) = xWs.Cells(i + 1, 15)
'Debug.Print rng1(i), rng2(i)
Next
Debug.Print "done reading LocIDs & emails"
End Sub
I'm trying to get my head around how I would write an inbox to maintain an inbox with subfolders listed by domain e.g. :
Inbox->#client1.com->client1 e-mails
I had a poke around on here and this is close to what I'm trying to get at:
Move e-mails by senderemailaddress outlook macro
Option Explicit
Public Sub Move_Items()
'// Declare your Variables
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim Folder As Outlook.MAPIFolder '<- has been added
Dim olNs As Outlook.NameSpace
Dim Item As Outlook.MailItem
Dim Items As Outlook.Items
Dim lngCount As Long
' On Error GoTo MsgErr
'// Set Inbox Reference
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Folder = Application.Session.PickFolder
Set Items = Inbox.Items
'// Loop through the Items in the folder backwards
For lngCount = Inbox.Items.Count To 1 Step -1
Set Item = Inbox.Items.Item(lngCount)
Debug.Print Item.Subject
If Item.Class = olMail Then
Select Case Item.SenderEmailAddress
' // Email_One
Case "bb#gmail.com"
' // Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Temp")
Set Item = Items.Find("[SenderEmailAddress] = 'bb#gmail.com'")
If TypeName(Item) <> "Nothing" Then
' // Mark As Read
Item.UnRead = False
' // Move Mail Item to sub Folder
Item.Move SubFolder
End If
' // Email_Two
Case "aa#gmail.com"
' // Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Temp")
Set Item = Items.Find("[SenderEmailAddress] = 'aa#gmail.com'")
If TypeName(Item) <> "Nothing" Then
' // Mark As Read
Item.UnRead = False
' // Move Mail Item to sub Folder
Item.Move SubFolder
End If
End Select
End If
Next lngCount
MsgErr_Exit:
Set Inbox = Nothing
Set SubFolder = Nothing
Set olNs = Nothing
Set Item = Nothing
Set Items = Nothing
Exit Sub
'// Error information
MsgErr:
MsgBox "An unexpected Error has occurred." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MsgErr_Exit
End Sub
What it is missing is the automation piece however, I'm looking for a "run and file" approach where it checks if the subfolder exists. (e.g. #client1.com)
If the subfolder does exist and the domain matches, move the e-mail there. If it does not, create new subfolder for the client with a new domain and file it in there.
Can anyone assist?
Simply use Right - Len - Instr and Split Function
Example
Dim FolderName As String
FolderName = Right("bb#gmail.com", _
Len("bb#gmail.com") _
- InStr("bb#gmail.com", "#"))
Debug.Print FolderName 'Immediate Window prints gmail.com
FolderName = "#" & FolderName
Debug.Print FolderName 'Immediate Window prints #gmail.com
Once you have FolderName then check if folder Exists or else create one
If FolderExists(Inbox, FolderName) = True Then
Set SubFolder = Inbox.Folders(FolderName)
Else
Set SubFolder = Inbox.Folders.Add(FolderName)
End If
'// Function - Check folder Exist
Private Function FolderExists(Inbox As MAPIFolder, FolderName As String)
Dim Sub_Folder As MAPIFolder
On Error GoTo Exit_Err
Set Sub_Folder = Inbox.Folders(FolderName)
FolderExists = True
Exit Function
Exit_Err:
FolderExists = False
End Function
Your code should look like
If Item.Class = olMail Then
Select Case Item.SenderEmailAddress
' // Email_One
Case "bb#gmail.com"
' // Set SubFolder of Inbox
Dim FolderName As String
FolderName = Right("bb#gmail.com", _
Len("bb#gmail.com") _
- InStr("bb#gmail.com", "#"))
Debug.Print FolderName 'Immediate Window prints gmail.com
FolderName = "#" & FolderName
Debug.Print FolderName 'Immediate Window prints #gmail.com
'// Check if folder exist else create one
If FolderExists(Inbox, FolderName) = True Then
Set SubFolder = Inbox.Folders(FolderName)
Else
Set SubFolder = Inbox.Folders.Add(FolderName)
End If
Add your Private Function FolderExists after End Sub
Basically I have a list of 5000 strings populated in an Excel spreadsheet. I want VBA to go through the attachments in an Outlook Inbox and if it finds a string match, I want the particular email to be flagged. Here's the code I have so far
Sub attachsearch()
On Error GoTo bigerror
Dim ns As Namespace
Dim inbox As MAPIFolder
Dim subfolder As MAPIFolder
Dim item As Object
Dim atmt As Attachment
Dim filename As String
Dim i As Integer
Dim varresponse As VbMsgBoxResult
Dim workbk As Workbook
Dim SearchString As String
Set ns = GetNamespace("MAPI")
Set inbox = ns.GetDefaultFolder(olFolderInbox)
Set subfolder = inbox.Folders("test")
Set workbk = Workbooks.Open("C:\Users\John.Doe\Desktop\10 25 2016 Pricing Team Macro.xlsm")
i = 0
If subfolder.Items.Count = 0 Then
MsgBox "There are no emails to look at. Please stop wasting my time.", vbInformation, "Folder is Empty"
Exit Sub
End If
For Each item In subfolder.Items
For Each atmt In item.Attachments
For rwindex = 1 To 5000
SearchString = Workbooks("10 25 2016 Pricing Team Macro").Sheets("NDC Sort").Cells(rwindex, 1).Value
Below is the problem code, index proberty is not used correctly here, but I'm unsure what to use. I know that Microsoft indexes the words within the attachment because when I manually type in the search string in Outlook, it pulls up the email even though the string is only present within the attachment. So ultimately, my question is, how do I leverage that attachment index in VBA?
If atmt.Index Like "*" & Workbooks("10 25 2016 Pricing Team Macro").Sheets("NDC Sort").Cells(rwindex, 1).Value & "*" Then
i = i + 1
With item
.FlagRequest = "Follow up"
.Save
End With
End If
Next rwindex
Next atmt
Next item
If i > 0 Then
MsgBox "I found " & i & " attached files with a specific name."
Else
MsgBox "I didn't find any files"
End If
Set atmt = Nothing
Set item = Nothing
Set ns = Nothing
workbk.Close savechanges:=False
Exit Sub
bigerror:
MsgBox "something went wrong"
End Sub
Any help would be greatly appreciated, thanks in advance!
Here's a solution if you only need to search the contents PDFs, MSWord, and Excel. There's a different procedure for each. A caveat is that you need to have a version of Adobe that you pay for. This won't work on plain Adobe Reader. I've tested it a few times and it works, but it seems kind of chunky in some parts so I'm open to suggestions.
Sub attachsearch()
Dim ns As Namespace
Dim inbox As MAPIFolder
Dim subfolder As MAPIFolder
Dim item As Object
Dim atmt As Attachment
Dim tempfilepath As String
Dim tempfilename As String
Dim i As Integer
Dim workbk As Workbook
Dim LastRow As Long
Dim TextToFind As String
Dim Loc As Range
Dim Sh As Worksheet
Dim WS_Count As Integer
Dim x As Integer
Dim WS_Name As String
Set ns = GetNamespace("MAPI")
Set inbox = ns.GetDefaultFolder(olFolderInbox)
Set subfolder = inbox.Folders("test")
Set workbk = Workbooks.Open("C:\Users\John.Doe\Desktop\10 25 2016 Pricing Team Macro.xlsx")
LastRow = Workbooks("10 25 2016 Pricing Team Macro").Worksheets("NDC Sort").Cells(Worksheets("NDC Sort").Rows.Count, "A").End(xlUp).Row
i = 0
If subfolder.Items.Count = 0 Then
MsgBox "There are no emails to look at. Please stop wasting my time.", vbInformation, "Folder is Empty"
Exit Sub
End If
For Each item In subfolder.Items
For Each atmt In item.Attachments
If item.FlagStatus = Empty Then
If Right(atmt.Filename, 4) Like "xl**" Or Right(atmt.Filename, 3) Like "xl*" Then
tempfilepath = "O:\aaaTEST\"
tempfilename = Format(item.ReceivedTime, "yyyymmdd_hhnnss_") & item.SenderName & "_" & atmt.Filename
atmt.SaveAsFile tempfilepath & tempfilename
Workbooks.Open (tempfilepath & tempfilename)
Workbooks(tempfilename).Activate
WS_Count = Workbooks(tempfilename).Worksheets.Count
'Clearing any selections that may limit the search unintentionally
For x = 1 To WS_Count
With ActiveWorkbook.Worksheets(x)
.Select
.Cells(1, 1).Select
Application.CutCopyMode = False
End With
Next x
For rwindex = 2 To LastRow
If item.FlagStatus = Empty Then
TextToFind = Workbooks("10 25 2016 Pricing Team Macro").Sheets("NDC Sort").Cells(rwindex, 1).Value
If TextToFind <> "" Then
Workbooks(tempfilename).Activate
For x = 1 To WS_Count
With ActiveWorkbook.Worksheets(x)
.Select
.UsedRange.Select
Set Loc = .Cells.Find(TextToFind)
If item.FlagStatus = Empty Then
If Not Loc Is Nothing Then
i = i + 1
With item
.FlagRequest = "Follow up"
.Save
End With
End If
End If
Set Loc = Nothing
End With
Next x
End If
End If
Next rwindex
Workbooks(tempfilename).Close Savechanges:=False
End If
'PDF Check
If Right(atmt.Filename, 3) = "pdf" Then
tempfilename = "O:\aaaTEST\" & _
Format(item.ReceivedTime, "yyyymmdd_hhnnss_") & item.SenderName & "_" & atmt.Filename
atmt.SaveAsFile tempfilename
PDFPath = tempfilename
Set App = CreateObject("AcroExch.App", "")
Set AVDoc = CreateObject("AcroExch.AVDoc")
If AVDoc.Open(PDFPath, "") = True Then
AVDoc.BringToFront
For rwindex = 2 To 3593
If item.FlagStatus = Empty Then
TextToFind = Workbooks("10 25 2016 Pricing Team Macro").Sheets("NDC Sort").Cells(rwindex, 1).Value
If AVDoc.FindText(TextToFind, False, True, False) = True Then
i = i + 1
With item
.FlagRequest = "Follow up"
.Save
End With
End If
AVDoc.Close True
App.Exit
End If
Next rwindex
End If
End If
'MSWord check
If Right(atmt.Filename, 4) Like "doc*" Or Right(atmt.Filename, 3) Like "doc" Then
tempfilepath = "O:\aaaTEST\"
tempfilename = Format(item.ReceivedTime, "yyyymmdd_hhnnss_") & item.SenderName & "_" & atmt.Filename
atmt.SaveAsFile tempfilepath & tempfilename
Set wordapp = CreateObject("word.Application")
wordapp.Documents.Open Filename:=tempfilepath & tempfilename
wordapp.Visible = True
For rwindex = 2 To 5
If item.FlagStatus = Empty Then
TextToFind = Workbooks("10 25 2016 Pricing Team Macro").Sheets("NDC Sort").Cells(rwindex, 1).Value
If TextToFind <> "" Then
With wordapp.ActiveDocument.Content.Find
.ClearFormatting
.Execute FindText:=TextToFind
If .Found = True Then
i = i + 1
With item
.FlagRequest = "Follow up"
.Save
End With
End If
End With
End If
End If
Next rwindex
wordapp.ActiveDocument.Close Savechanges:=wdDoNotSaveChanges
wordapp.Quit Savechanges:=wdDoNotSaveChanges
End If
End If
Next atmt
Next item
Workbooks("10 25 2016 Pricing Team Macro").Close Savechanges:=False
If i > 0 Then
MsgBox "I found " & i & " attached files with a specific name."
Else
MsgBox "I didn't find any files"
End If
Set atmt = Nothing
Set item = Nothing
Set ns = Nothing
Exit Sub
End Sub
I want to move messages from the sender to the folder I created for the sender.
The SenderName is displayed as "Doe, John (US)" and my folder would be "Doe, John".
What do I need to do to compare the SenderName to a subfolder name that is two levels below "Inbox". I.e. 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
Assumptions
The sender subfolders will be two levels below inbox but not under a single parent folder (i.e. "Doe, John" could appear under Folder1 and "Doe, Jane" under Folder2)
All emails that should be processed by the macro will be selected before executing it
The code should not create subfolders for missing senders - as there are multiple possible "parent" folders - but should output a message containing a list of missing sender folders
Conditions that trigger the end of a sender name:
A hyphen following or preceding a space (i.e. "Doe, John - US" = "Doe, John" and "Huntington-Whiteley, Rosie - CAN" = Huntington-Whiteley, Rosie")
The second instance of a comma (i.e. "Doe, John, CPA" = "Doe, John")
The second instance of a space (i.e. "Doe, John Q" = "Doe, John")
An apostrophe preceded or followed by a space (i.e. "O'Leary, John" = "O'Leary, John" but "Doe, John 'US'" = "Doe, John")
Any other non-alphabetical character (i.e. "Doe, John: US" = "Doe, John"
Proposed Solution
This code will satisfy all of the above conditions, and will output a single message at the end denoting any senders for whom folders could not be found (as opposed to a separate message for each email). It has been tested on 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
The goal appears to be organizing selected mail items based on the SenderName when invoked.
Have put a bit further as you can move items within a folder of choice when nothing in selection moved (ie. selected meeting items only).
When picking a folder to process items, the folder cannot be the main sub folder or it's 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's 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's comment
Searches all the sub folders within Inbox for the Sender's Name. If not found, prompts to create from Folder Picker.
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
Update 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