Outlook
A family of Microsoft email and calendar products.
3,009 questions
This browser is no longer supported.
Upgrade to Microsoft Edge to take advantage of the latest features, security updates, and technical support.
Hello,
I work at @mycompany.com" and I would need to write a VBA macro to move all emails originated other than "@mycompany.com."
What I have tried:
Please advise.
Private WithEvents Items As Outlook.Items
Private Explorer As Outlook.Explorer
Private Sub Application_Startup()
' Reference the items in the Inbox
Set Items = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items
' Get the current Explorer
Set Explorer = Application.ActiveExplorer
' Collapse the "Archive" folder
CollapseArchiveFolder
End Sub
Private Sub CollapseArchiveFolder()
Dim ns As Outlook.NameSpace
Dim archiveFolder As Outlook.folder
Set ns = Application.GetNamespace("MAPI")
On Error Resume Next
Set archiveFolder = ns.Folders("myalias@mycomapny.com).Folders("Archive")
On Error GoTo 0
If Not archiveFolder Is Nothing Then
Explorer.SelectFolder archiveFolder
SendKeys "{LEFT}"
Else
MsgBox "Archive folder not found!", vbExclamation
End If
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim destFolder As Outlook.folder
Dim myNamespace As Outlook.NameSpace
Set myNamespace = Application.GetNamespace("MAPI")
' Adjust the folder path if "Non_@mycompany is not directly under the mailbox root
Set destFolder = myNamespace.Folders("myalias@mycomapny.com").Folders("Archive").Folders("Non_UMD")
If TypeName(Item) = "MailItem" Then
Dim mail As Outlook.mailItem
Set mail = Item
' Move if the sender's email address does not contain "umassd"
If InStr(1, mail.SenderEmailAddress, "umassd", vbTextCompare) = 0 Then
mail.Move destFolder
End If
End If
Exit Sub
ErrorHandler:
MsgBox "An error has occurred: " & Err.Description
End Sub