I'm using your Move aged email macro. I tweaked it a little so that instead of moving all of the mail to one folder I have it going to folders based on the sender's name. Now what I would like to do is, when the macro looks for the sender's name if there is not a folder, one will be created.
The following two macros will move the messages to a folder named for the sender, creating the folder if it does not exist. The first macro works on selected messages in any folder, moving the messages to subfolders under the current folder. The second macro is the one Joel tweaked and needed help with the code to create the folder.
Creating a new folder is just a couple of lines. By using On Error Resume Next, you can set the folder variable and next line runs if an error is encountered. This is important because an error will be triggered when you try to set the destination folder to a folder that doesn't exist. The next lines tell Outlook to create the folder if it doesn't exist.
On Error Resume Next
Set objDestFolder = objSourceFolder.Folders(sSenderName)
If objDestFolder Is Nothing Then
Set objDestFolder = objSourceFolder.Folders.Add(sSenderName)
End If
File selected messages by sender's name
While I'm not a big fan of filing messages in hundreds of folders, I can see the value in filing some messages. This version of the macros works on the selected message(s) and creates a subfolder in the current folder.
Public Sub MoveSelectedMessages()
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 objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set currentExplorer = objOutlook.ActiveExplorer
Set Selection = currentExplorer.Selection
Set objSourceFolder = currentExplorer.CurrentFolder
For Each obj In Selection
Set objVariant = obj
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.SentOn, Now)
' I'm using 40 days, adjust as needed.
If intDateDiff > 40 Then
sSenderName = objVariant.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = objVariant.SenderName
End If
On Error Resume Next
' Use These lines if the destination folder is not a subfolder of the current folder
' Dim objInbox As Outlook.MAPIFolder
' Set objInbox = objNamespace.Folders("alias@domain.com"). _
Folders("Inbox") ' or whereever the folder is
' Set objDestFolder = objInbox.Folders(sSenderName)
Set objDestFolder = objSourceFolder.Folders(sSenderName)
If objDestFolder Is Nothing Then
Set objDestFolder = objSourceFolder.Folders.Add(sSenderName)
End If
objVariant.Move objDestFolder
'count the # of items moved
lngMovedItems = lngMovedItems + 1
Set objDestFolder = Nothing
End If
End If
Err.Clear
Next
' Display the number of items that were moved.
MsgBox "Moved " & lngMovedItems & " messages(s)."
Set currentExplorer = Nothing
Set obj = Nothing
Set Selection = Nothing
Set objOutlook = Nothing
Set objNamespace = Nothing
Set objSourceFolder = Nothing
End Sub
File aged messages by sender's name
This version of the macro moves messages to an Inbox subfolder named for the sender. It looks for the display name, and if a folder does not exist, it creates it. If the sender uses different email clients, the messages may be filed in several folders. Using the sender's email address would eliminate this problem, but make it harder to know who each folder is for.
Sub MoveAgedMail()
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objDestFolder As Outlook.MAPIFolder
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
For intCount = objSourceFolder.Items.Count To 1 Step -1
Set objVariant = objSourceFolder.Items.Item(intCount)
DoEvents
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.SentOn, Now)
' I'm using 40 days, adjust as needed.
If intDateDiff > 40 Then
' use your datafile name and each folder in the path
' the example uses an email address because Outlook 2010
' uses email addresses for datafile names
sSenderName = objVariant.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = objVariant.SenderName
End If
On Error Resume Next
Set objDestFolder = objSourceFolder.Folders(sSenderName)
If objDestFolder Is Nothing Then
Set objDestFolder = objSourceFolder.Folders.Add(sSenderName)
End If
objVariant.Move objDestFolder
'count the # of items moved
lngMovedItems = lngMovedItems + 1
Set objDestFolder = Nothing
End If
End If
Next
' Display the number of items that were moved.
MsgBox "Moved " & lngMovedItems & " messages(s)."
Set objOutlook = Nothing
Set objNamespace = Nothing
Set objSourceFolder = Nothing
End Sub
File by Year
This code snippet shows how to file messages by year, moving only those messages that are older than a year.
Dim intYear As String
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.ReceivedTime, Date)
Debug.Print Date & " " & intDateDiff
If intDateDiff > 365 Then
intYear = Year(objVariant.ReceivedTime)
Debug.Print objVariant.Subject & "--" & intYear
On Error Resume Next
Set objDestFolder = objSourceFolder.Folders(intYear)
' Debug.Print objDestFolder
If objDestFolder Is Nothing Then
Set objDestFolder = objSourceFolder.Folders.Add(intYear)
End If
objVariant.Move objDestFolder
'count the # of items moved
lngMovedItems = lngMovedItems + 1
Set objDestFolder = Nothing
End If
Err.Clear
End If
Next
File Messages as they arrive
This ItemAdd macro runs as messages hit the default inbox and file messages to a subfolder of the Inbox, by the sender's display name. To use SMTP address, change SenderName to SenderEmailAddress, note however, that if you use Exchange server, you will need to get the Exchange SMTP.
Option Explicit
Private objNS As Outlook.NameSpace
Private WithEvents objItems As Outlook.Items
Private Sub Application_Startup()
Dim objWatchFolder As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")
'Set the folder and items to watch:
Set objWatchFolder = objNS.GetDefaultFolder(olFolderInbox)
Set objItems = objWatchFolder.Items
Set objWatchFolder = Nothing
End Sub
Private Sub objItems_ItemAdd(ByVal Item As Object)
Dim objParentFolder As Outlook.Folder
Dim objDestFolder As Outlook.Folder
Dim objVariant As Variant
Dim sSenderName As String
Set objVariant = Item
Set objParentFolder = objNS.GetDefaultFolder(olFolderInbox)
If objVariant.Class = olMail Then
sSenderName = objVariant.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = objVariant.SenderName
End If
On Error Resume Next
Set objDestFolder = objParentFolder.Folders(sSenderName)
If objDestFolder Is Nothing Then
Set objDestFolder = objParentFolder.Folders.Add(sSenderName)
End If
objVariant.Move objDestFolder
Set objDestFolder = Nothing
End If
End Sub
How to use macros
First: You will need macro security set to low during testing.
To check your macro security in Outlook 2010 or 2013, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, it’s at Tools, Macro Security.
After you test the macro and see that it works, you can either leave macro security set to low or sign the macro.
Open the VBA Editor by pressing Alt+F11 on your keyboard.
To put the code in a module:
- Right click on Project1 and choose Insert > Module
- Copy and paste the macro into the new module.
More information as well as screenshots are at How to use the VBA Editor
Simon Chaung says
Hi Diane,
Thanks for your perfect work, the "File aged messages by sender's name" script does help me a lot for filing mails.But, can I have your advise that how I could change the destination folder from "Inbox" to some kind like: "Archive" which would be the same level with "Inbox"?
Pravin Elliah says
Hello Diane,
Could you please help in modifying the following script, so that it creates a subfolder with the sender name in the 'domain' folder? For e.g email from test@domain.com, folders will
be domain.com/test/
This will be very helpful for many people.
Public Sub MoveSelectedToDomain()
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 objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set currentExplorer = objOutlook.ActiveExplorer
Set Selection = currentExplorer.Selection
Set objSourceFolder = currentExplorer.CurrentFolder
For Each obj In Selection
Set objVariant = obj
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.SentOn, Now)
' I'm using 40 days, adjust as needed.
If intDateDiff >= 0 Then
sSenderName = Right(objVariant.SenderEmailAddress, Len(objVariant.SenderEmailAddress) - InStr(objVariant.SenderEmailAddress, "@"))
If sSenderName = ";" Then
sSenderName = objVariant.SenderName
End If
On Error Resume Next
Set objDestFolder = objNamespace.Folders("OutlookEmail").Folders(sSenderName)
'Set objDestFolder = objDestFolder.Folders(sSenderName)
If objDestFolder Is Nothing Then
Set objDestFolder = objNamespace.Folders("OutlookEmail").Folders.Add(sSenderName)
End If
objVariant.Move objDestFolder
'count the # of items moved
lngMovedItems = lngMovedItems + 1
Set objDestFolder = Nothing
End If
End If
Err.Clear
Next
' Display the number of items that were moved.
' MsgBox "Moved " & lngMovedItems & " messages(s)."
Set currentExplorer = Nothing
Set obj = Nothing
Set Selection = Nothing
Set objOutlook = Nothing
Set objNamespace = Nothing
Set objSourceFolder = Nothing
End Sub
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
End Sub
Gregory Ash says
Any way to sort in folders by conversation
Joshua says
Is their any way to have it create the folder by the domain of the email?
Diane Poremsky says
Yes - you'd change this line to use the domain: sSenderName = objVariant.SentOnBehalfOfName
sSenderName = Right(objVariant.SenderEmailAddress, Len(objVariant.SenderEmailAddress) - InStr(objVariant.SenderEmailAddress, "@"))
George Issa says
Hi Diane,
I know I'm a few years late, but I absolutely love your macro of filing emails into senders folder names, and want to thankyou deeply.
I'm having trouble getting the code to recognise when I have moved the folder to a subfolder. I've tried all the suggestions in the comments but to no luck.
Ideally Id like to file emails to the folder irrespective of where it is in the folder tree. That might be two or 3 sub fodders deep from the Inbox level. Any help would be really, really appreciated. Thankyou kindly :)
Diane Poremsky says
I have a macro that looks up a folder - but i have not used it nested folders - all of the folders were under Inbox\Clients\. I'll need to work it into in the macro - i believe you'd replace Set objDestFolder = objSourceFolder.Folders(sSenderName) with FindFolder
(Actually, i borrowed it from Michael Bauer - http://vboffice.net/en/developers/find-folder-by-name)
Public Sub FindFolder()
Dim Name$
Dim Folders As Outlook.Folders
Dim Folder As Outlook.MAPIFolder
Set m_Folder = Nothing
m_Find = ""
Name = "*" & strCode
If Len(Trim$(Name)) = 0 Then Exit Sub
m_Find = Name
m_Find = LCase$(m_Find)
Set Folder = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("Clients")
LoopFolders Folder.Folders
End Sub
Private Sub LoopFolders(Folders As Outlook.Folders)
Dim Folder As Outlook.MAPIFolder
Dim F As Outlook.MAPIFolder
Dim Found As Boolean
If SpeedUp = False Then DoEvents
For Each F In Folders
Found = (LCase$(F.Name) Like m_Find)
If Found Then
Set m_Folder = F
Exit For
Else
LoopFolders F.Folders
If Not m_Folder Is Nothing Then Exit For
End If
Next
End Sub
Jeremy Smith says
Hi Diane,
I wanted to know how this could be modified to accomodate distribution lists or recipients. The short of it is this. I work in an environment where the are literally a few hundred emails that flood my inbox per day. I would like to move everything back into my inbox as I have something conflicting with my rules. However, some emails that come in are sent to a distro and some are sent directly to me. The Senders of the emails can come from a distribution group or from an individual.
For example: emails for the Help Desk come from individuals. However when there is a major incident and we email out the email comes from a distribution group named incident reporting.
I have mapped out the folders in a word document - and figure that I would need a Case statement or nested IF ELSE statements, but do not know how to access different aspects of the Mail Item Object.
Any insights would be much appreciated.
Thanks
Jeremy
Oscar Perez says
Diane, when I first found your VBA script over 2 ½ years ago, I thought it was heaven sent. I don’t VBA and my current position doesn’t allow me the opportunity to learn what I need, just come up with ideas. I finally ran your script a year later and it produced 500+ folders, which was crazy. Any chance you can create a folder by domain name and then another folder in that folder by the sender from that domain. That would cut down my folders by 65-75%. Another idea, since some domains are just letters (ex. bcad.org, for Bexar County Appraisal District) is it possible for it to look at a table that translates a domains letters to a more clear description and create a folder from that? If it don’t find the domain name in the table it doesn’t do anything, indicating to me that I have to modify the table. Hope you can help. This is just for personal use.
Diane Poremsky says
Yeah, it creates a crazy number of folders - i made the mistake of testing it on my inbox. Ouch. Moving everything back was a pita. :)
It would be possible to file by by domain then by alias or address - you need to create the domain folder then check for the alias. (I don't have any samples that do it) - or you could file by domain then sort or group by sender, to reduce the number of folders.
Michel Fontaine says
I've tested the both macro (aged message and selected messages) on Office 365 (version 2016) and I have an issue. The folders are created based on senders names but the messages associated to the senders name remain at their original location and are not moved in the newly created folders. Also I would like to be able to first create a folder of the domain and then subfolders of the senders of that domain. Also would it be possible to remove the empty space at the beginning of the folder name if any in order sort properly folders even if the sender name start with a space (space would be removed in folder name). Could to send me the sample of code required to fixe the issue and the other 2 enhancements requested ?
Diane Poremsky says
Removing the space should be fairly easy - use the Trim function. replace sSenderName with Trim(sSenderName) in the line that creates the folder.
Creating domain folders then adding the subfodlers would be a bit more complicated (do-able but complicated). You need to get the domain name then create the folder and set it as the parent for the destination folder. I don't have any sample code that does this, only sample code that gets the domain name.
strDomain = Right(objMail.SenderEmailAddress, Len(objMail.SenderEmailAddress) - InStr(objMail.SenderEmailAddress, "@"))
Martin Green says
This is a pretty cool tool, but I would like messages auto filed to previously named folders, only as a user initiated option provided either by a toolbar button or prompt. This is very much like move after read or reply rules, but I want the ability for the user to choose rather than an automated or timed process. To me, it's simply a missing option to be added to existing Outlook rules.
SteveB says
Whoa I have been waiting for this macro for so long.
Is it possible to move to the root (same level as inbox? How?
Is it possible to select different senders at the same time and create folder for each of them instead of one by one?
Again thanks for your time.
Diane Poremsky says
Sure. Just change the path for the destination code. If you want it at the same level as the currently selected folder, add .parent to the destination path:
Set objSourceFolder = currentExplorer.CurrentFolder
Set objDestFolder = objSourceFolder.parent.Folders(sSenderName)
if you want it at the inbox level regardless of the source folder, use
Set objDestFolder = Session.GetDefaultFolder(olFolderInbox).parent.Folders(sSenderName)
Not sure what you mean by selecting different senders - outlook will only create a folder if one does not exist for the sender so there really isn't a reason to create the folders first. (It wouldn't speed it up either). If you really want to, you could delete this line - objVariant.Move objDestFolder - it'll create the folders but not move mail into them.)
Set objDestFolder = objSourceFolder.Folders(sSenderName)
If objDestFolder Is Nothing Then
Set objDestFolder = objSourceFolder.Folders.Add(sSenderName)
Steve B says
HI Diane,
Thank you so much for the quick reply as well as the quality of the answer.
What I meant by multiple senders is: I have four emails in my inbox, 3 from one sender (John) and 1 from another sender (Mike). Can I select the four emails in the inbox and initiate the macro so that the two different folers will be created ans the emails will then be transfered. Like a bulk transfer.
Other and last point because so far your method is like greeting season before time :), the method do not transfer the emails if the sender's folders already exist, is there a way that it transfers the emails if the folder already exist?
Sorry if I'm not clear enough, english isn't my first language.
Thanks
Steve
kent says
Hi Diane,
This is a useful macro which i have implemented with great success. Also, I noticed in the first source code, there was a slight typo:
' I'm using 40 days, adjust as needed.
If intDateDiff > 4 Then
the text should read;
' I'm using 4 days, adjust as needed.
Also, I wanted to get your guidance on how i would implement a sub folder within current folder (i.e. inbox) I noticed you ddid have some code for for when the sub folder was not within the current folder, but for my application I'd like to add "staff" as a sub folder to the current folder.
Diane Poremsky says
To use a subfolder of the inbox - you can do it two ways - set the sourcefolder to default to the inbox or leave it on current folder and just set the destination folder to a subfolder of the inbox
change
Set objSourceFolder = currentExplorer.CurrentFolder
to
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
then this will use a subfolder of the inbox.
Set objDestFolder = objSourceFolder.Folders(sSenderName)
or use this for the destination folder:
Set objDestFolder = objNamespace.GetDefaultFolder(olFolderInbox).Folders(sSenderName)
Chris says
Diane,
I am interested in the macro to "File selected messages by sender's name" and would like to use it but with a modification.
For email received from a domain other than my company domain, file all emails in a folder based on the domain name. For example if I receive an email from bgates@microsoft, pallen@microsoft etc I would like to store the emails in a folder named "Microsoft".
If the email is from a person in my company I would like to store the email in a folder based on the persons name. Which I think I can use the code you already posted. But I am not sure what new code would need to be added.
Diane Poremsky says
The first part is fairly easy look for sender email address and grab the part to the right of the @ then split it again at the .
This code works as long as the address has one dot - if you need it to work on 2 dots (@e.microsoft.com) you'll need to do it a little differently - get the length of the array and subtract 1.
Dim sArray() As String
Dim sSenderName As String
For Each obj In Selection
Set objVariant = obj
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.SentOn, Now)
If intDateDiff > 4 Then
sSenderName = objVariant.SenderEmailAddress
sArray = Split(sSenderName, "@")
sSenderName = sArray(1) ' right of @
MsgBox sSenderName
sArray = Split(sSenderName, ".")
sSenderName = sArray(0) ' left of first .
MsgBox sSenderName
jcolby57120 says
Thank you very much for posting this marco.
Could the users domain be used in place to their name? I've used your other marco on this site to add the senders domain and have been manually trying file them. Ideally what I'm looking for is to create a folder based on a domain, then a subfolder based on send.
Any help is greatly appreciated.
Diane Poremsky says
You can - the macro at https://www.slipstick.com/outlook/email/sort-messages-sender-domain/ adds the domain to a new field but you'd use the same method of grabbing the domain in this macro.
this code assumes you aren't using exchange server or are not applying the macro to internal mail
If intDateDiff > 4 Then
sSenderName = objVariant.SenderEmailAddress
sSenderName = Right(sSenderName , Len(sSenderName) - InStr(sSenderName , "@"))
On Error Resume Next
Zach says
Is it possible to tweak this so that it selects and files an entire conversation string based off the original sender?
Example - Brittany W. send first email and receives 5 replies. I would like to select the conversation using this code and have it file under Brittany W. or create a new folder named Brittany W. if one does not exist just as this does for single emails.
Diane Poremsky says
I found a sample at msdn to tweak. My changes are kinda half working - the folder is created and items copied, not moved.
The original code is here: https://code.msdn.microsoft.com/office/Outlook-2010-Manipulate-64fead5e
Public Sub GetConverstationInformation()
Dim host As Outlook.Application
Set host = ThisOutlookSession.Application
Dim selectedItem As Object
Dim theMailItem As Outlook.mailitem
Dim sSendername
Dim objDestFolder As Outlook.MAPIFolder
Dim objSourceFolder As Outlook.folder
Set objSourceFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent.Folders("Archive")
' Get the user's currently selected item.
Set selectedItem = host.ActiveExplorer.Selection.Item(1)
Set theMailItem = selectedItem
Dim parentFolder As Outlook.folder
Dim parentStore As Outlook.Store
Set parentFolder = theMailItem.Parent
Set parentStore = parentFolder.Store
If parentStore.IsConversationEnabled Then
Dim theConversation As Outlook.Conversation
Set theConversation = theMailItem.GetConversation
If Not IsNull(theConversation) Then
Dim itemsTable As Outlook.Table
Set itemsTable = theConversation.GetTable
Dim group As Outlook.SimpleItems
Set group = theConversation.GetRootItems
Dim obj As Object
Dim fld As Outlook.folder
Dim mi As Outlook.mailitem
sSendername = theConversation.Parent.SentOnBehalfOfName
If sSendername = ";" Then
sSendername = theConversation.Parent.SenderName
End If
On Error Resume Next
Set objDestFolder = objSourceFolder.Folders(sSendername)
If objDestFolder Is Nothing Then
Set objDestFolder = objSourceFolder.Folders.Add(sSendername)
End If
For Each obj In group
obj.Move objDestFolder
Next
End If
End If
End Sub
Tümer says
Dear Diane,
first of all thank you for reply :) as actually require when ı sent an e-mail sent mail has to move ==> 2015 -- "X person name folder " ı try several times but I cant do it. when ı saw your code I try and guess maybe ı change to use for sentitem folder and make sub folders for when ı use it.
sorry I made mistake giving wrong macro code name: "Sub MoveAgedMail() " when ı use Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox) macro says " move 0 mail" but when ı change to olfolderSentitems result is " run time error
Diane Poremsky says
in the sent folder, you are the sender. You'd need to use the To field, but it won't work correctly when you send to multiple recipients. Anyway, the correct folder name is olFolderSentMail sorry about that.
Mitch Mitchell says
I am encouraged by your code but it results in an error on the sSender as not having definition. Tried Dimming as String(same result) and Object(No error but no files moved either). Am I missing something?
Diane Poremsky says
it should be dimmed as a string. do any messages meet the condition in the IF statement - ie, received 40 days ago?
Tümer says
Dear Diane
thank you for the macros and web pages. ı try <Macro to file Outlook email by sender's display name - File selected messages by sender's name< ı use gmail with outlook ıts work perfect but when ı use for company e-mail its not work. ıs there somethink ı miss ? (company mail exchange server).
would you help me ? and how can ı change the code for inbox to sent items folder
Diane Poremsky says
What happens when you use it on the work account? As long as you are using the display name, it should work. (I tested it on an exchange mailbox.) Filing by email address won't work very well with messages from coworkers, because the exchange address is long and ugly.
Diane Poremsky says
Oh, and for the sent folder, the first macro works on the selected folder, The second one uses this line to set the folder:
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
change the folder to olFolderSentMail.
Z Gansad says
Hi,
Is there a macro to reset the actions done by this VBA?
The 2nd script really worked too well .. I just realized I created 200+ folders from all the senders :(
Thanks
Diane Poremsky says
:) I did the same thing when I tested it on my mailbox. I don't know why people think filing mail like that is better than using instant search. :) I don't have a macro, but a search folder should find everything then use the move to folder command.
I think i have a macro around here to delete the folders, but you can drag them into each other then delete the last one.
jonathandire says
Hi Diane,
I am trying to use the above method to prompt the user to save the email to folder and then send. (the save & send button is disabled for sharedinboxes here).
The code I've gotten so far is:
Private Sub Application_ItemSend(ByVal Item As Object, _
Cancel As Boolean)
Dim objNS As NameSpace
Dim objFolder As MAPIFolder
Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.PickFolder
If TypeName(objFolder) "Nothing" And _
IsInDefaultStore(objFolder) Then
Set Item.SaveSentMessageFolder = objFolder
End If
Set objFolder = Nothing
Set objNS = Nothing
End Sub
Public Function IsInDefaultStore(objOL As Object) As Boolean
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objInbox As Outlook.MAPIFolder
On Error Resume Next
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Select Case objOL.Class
Case olFolder
If objOL.StoreID = objInbox.StoreID Then
IsInDefaultStore = True
End If
Case olAppointment, olContact, olDistributionList, _
olJournal, olMail, olNote, olPost, olTask
If objOL.Parent.StoreID = objInbox.StoreID Then
IsInDefaultStore = True
End If
Case Else
MsgBox "This function isn't designed to work " & _
"with " & TypeName(objOL) & _
" items and will return False.", _
, "IsInDefaultStore"
End Select
Set objApp = Nothing
Set objNS = Nothing
Set objInbox = Nothing
End Function
The only problem I have is, that is it prompts the user to save to a folder, for every email.
I wanted to use a button just like save and send to only provide the option when clicked and then send the email once the folder is selected.
Could you please help if you get a chance?
Diane Poremsky says
This:
Private Sub Application_ItemSend(ByVal Item As Object, _
Cancel As Boolean)
tells it to check when you send every message. If you want to check only when you press a special Send button, you won't use an itemsend macro.
if you want ot use an itemsend macro, you need to use an if statement to apply it to certain messages.
Oscar says
Thank you, once again.
Oscar says
Diane, as previously posted this script was just the perfect code that I needed, but first time around it only moved about half of my emails and took a very long time. I have been trying to move the other half of my emails and it doesn’t seem to do anything. I don’t know VBA, but I know enough about coding to make me dangerous, so I added a debug.print right after the DoEvents to show the if the objVariant.Class was equal to olMail and it shows objVariant.Class to be equal to 53 or 54 and olMail to be equal to 43 for the remaining emails. I don’t know what does numbers mean or where to look. Can you please help?
Diane Poremsky says
The code is looking for olmail, not reports or meetings - 53 is a meeting request, 54 is a meeting cancellation. One macro at https://www.slipstick.com/developer/macro-move-aged-mail/ uses select case to file different message types. Of course, if you wanted everything filed based only on date, you can remove the line that looks for the message class.
Oscar Perez says
Your macro "File aged messages by sender's name" turned out to be the perfect code I needed. I'm not a programmer, but sometime I can figure out things and make them work for my needs. After using your code, it seems that the sender's name sometimes came across as just the First Name and others as First Last Name and other times as First Initial Last Name, so I have 2-3 folders for the same person. I thought if I could use a data dictionary, that I would have to manually update, where if the sender's name was different, but the email address was the same, I could file those emails under the same folder. Do you think that's possible and would you have some example code?
Diane Poremsky says
i have code that will file by email address, but I'll see if i can figure out a way to match email addresses and use friendly names.
Oscar Perez says
Thank you.