I see quite a few requests for help like this:
I'm receiving constant spam emails from a specific top-level domain. No legitimate sender I am in contact with would use this TLD and I would like to delete every single message from email addresses in this domain. The problem: they are snagged by the Junk folder, so any rules won't work. I can't effectively browse the Junk Email folder to see if any legitimate emails are in there, because I'm swamped with the spam.
Correct, rules won't work on mail if the junk email filter grabs it first, but you can run the rules on the Junk Email folder when you use Outlook desktop software.
- Add the Run Rules Now command to the Quick Access Toolbar or ribbon
- Select the Junk Email folder
- Click Run Rules Now button you added to the QAT or ribbon
- Select the Rule
- Click Run Now
You can also use an ItemAdd macro to watch the Junk Email folder and delete mail as it is added to the Junk Mail folder.
Use an ItemAdd macro
This simple macro watches the default Junk Email folder for messages from one top-level domain.
Notes: As written, these macros only work on the default junk email folder. If you have more than one data file, you'd need to watch each Junk Email folder. Or use the macro at the end of the page to run the ItemAdd macro on any folder in your profile. Also, the macro moves the junk mail to the Deleted items folder. VBA doesn't have a permanently delete command, so w need to move it to the Deleted Items and would need to delete it again.
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(olFolderJunk) Set objItems = objWatchFolder.Items Set objWatchFolder = Nothing End Sub ' ### ItemAdd macro Private Sub objItems_ItemAdd(ByVal Item As Object) Debug.Print Item.SenderEmailAddress ' change the TLD and the count If Right(Item.SenderEmailAddress, 3) = ".br" Then Item.Delete End If Set Item = Nothing End Sub ' ### End ItemAdd macro
To watch for multiple top-level domains in the default Junk Email folder, we'll use select case and an array. This allows us to check for TLDs of different lengths.
For the array, you'll use a comma-separated list of domains. If you want to delete longer TLDs (such as .trade), add another case block, where the Case value is the length of the TLD + 1 (for the .)
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(olFolderJunk) Set objItems = objWatchFolder.Items Set objWatchFolder = Nothing End Sub ' ## multi-TLD ItemAdd macro Private Sub objItems_ItemAdd(ByVal Item As Object) Dim arrTLD 'As variant Dim lenTLD As Long Dim i As Long 'Debug.Print Item.SenderEmailAddress 'Debug.Print InStrRev(Item.SenderEmailAddress, ".") lenTLD = Len(Item.SenderEmailAddress) - InStrRev(Item.SenderEmailAddress, ".") + 1 'Debug.Print lenTLD Select Case lenTLD Case 3 arrTLD = Array(".de", ".br", ".gq", ".tk", ".ga", ".it", ".tr", ".ml") GoTo checkdomain Case 4 arrTLD = Array(".org", ".xyz") GoTo checkdomain Case 5 arrTLD = Array(".live", ".club") GoTo checkdomain Case Else ' avoids errors a longer TLD is found Exit Sub End Select checkdomain: Debug.Print lenTLD, Right(LCase(Item.SenderEmailAddress), lenTLD) ' Go through the array and look for a match, then do something For i = LBound(arrTLD) To UBound(arrTLD) If Right(LCase(Item.SenderEmailAddress), lenTLD) = arrTLD(i) Then Item.Delete Exit Sub End If Next i Set Item = Nothing End Sub ' ## End multi-TLD ItemAdd macro
Watch folders in another data file
The macros above watch the Junk Email folder in your default data file. To watch the folder in another data file, you need to use the GetFolderPath function. To use it with Shared Exchange mailboxes, you need to use the shared mailbox code instead.
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(olFolderJunk) Set objWatchFolder = GetFolderPath("Outlook Data File\Junk Email") Set objItems = objWatchFolder.Items Set objWatchFolder = Nothing End Sub '### this can be replaced with the multi-TLD ItemAdd macro Private Sub objItems_ItemAdd(ByVal Item As Object) Debug.Print Item.SenderEmailAddress ' change the TLD and the count If Right(Item.SenderEmailAddress, 3) = ".br" Then Item.Delete End If Set Item = Nothing End Sub ' ### End ItemAdd ' from https://slipstick.me/qf Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder Dim oFolder As Outlook.Folder Dim FoldersArray As Variant Dim i As Integer On Error GoTo GetFolderPath_Error If Left(FolderPath, 2) = "\\" Then FolderPath = Right(FolderPath, Len(FolderPath) - 2) End If 'Convert folderpath to array FoldersArray = Split(FolderPath, "\") Set oFolder = Application.Session.Folders.Item(FoldersArray(0)) If Not oFolder Is Nothing Then For i = 1 To UBound(FoldersArray, 1) Dim SubFolders As Outlook.Folders Set SubFolders = oFolder.Folders Set oFolder = SubFolders.Item(FoldersArray(i)) If oFolder Is Nothing Then Set GetFolderPath = Nothing End If Next End If 'Return the oFolder Set GetFolderPath = oFolder Exit Function GetFolderPath_Error: Set GetFolderPath = Nothing Exit Function End Function
How to use the macros on this page
First: You need to have macro security set to the lowest setting, Enable all macros during testing. The macros will not work with the top two options that disable all macros or unsigned macros. You could choose the option Notification for all macros, then accept it each time you restart Outlook, however, because it's somewhat hard to sneak macros into Outlook (unlike in Word and Excel), allowing all macros is safe, especially during the testing phase. You can sign the macro when it is finished and change the macro security to notify.
To check your macro security in Outlook 2010 and newer, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, look 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.
Macros that run when Outlook starts or automatically need to be in ThisOutlookSession, all other macros should be put in a module, but most will also work if placed in ThisOutlookSession. (It's generally recommended to keep only the automatic macros in ThisOutlookSession and use modules for all other macros.) The instructions are below.
The macros on this page need to go into ThisOutlookSession.
Open the VBA Editor by pressing Alt+F11 on your keyboard.
To put the macro code in ThisOutlookSession:
- Expand Project1 and double click on ThisOutlookSession.
- Copy then paste the macro into ThisOutlookSession. (Click within the code, Select All using Ctrl+A, Ctrl+C to copy, Ctrl+V to paste.)
More information as well as screenshots are at How to use the VBA Editor
How to test an ItemAdd macro
To test an ItemAdd macro, you can either copy and paste one or more junk emails in place (Ctrl+C,V) or move mail into the folder you are watching. Or add the macro below at the end of ThisOutlookSession, then select a message and run the macro.
Sub RunScript() Dim objApp As Outlook.Application Dim objItem As MailItem Set objApp = Application Set objItem = objApp.ActiveExplorer.Selection.Item(1) 'macro name you want to run goes here objItems_ItemAdd objItem End Sub
To run either ItemAdd macro on all messages in any folder, use this macro call to call the ItemAdd macro.
Public Sub RunonAnyFolder() Dim objOL As Outlook.Application Dim objItems As Outlook.Items Dim objFolder As Outlook.MAPIFolder Dim obj As Object Dim i As Long Set objOL = Outlook.Application Set objFolder = objOL.ActiveExplorer.CurrentFolder Set objItems = objFolder.Items For i = objItems.Count To 1 Step -1 Set obj = objItems(i) 'macro name you want to run goes here objItems_ItemAdd obj Next Set obj = Nothing Set objItems = Nothing Set objFolder = Nothing Set objOL = Nothing End Sub
Thanks. I used the steps you outlined to create and run Rules on only the Junk folder and can now quickly clear out
80-90% of what is clearly Junk with just a few mouse clicks. I'm fine tuning the rules to get even more. I also added via forms a column to see the real email address of the sender (when possible) to further identity parameters for my Junk rules. Still work in progress but a quantum leap for me. Thanks again.