I am trying to move sent mail from my regular Sent Items standard folder to two separate folders in Outlook (365). On the left in my Folder Pane I have my email 'main#domain.com', 'Online Archive - main#domain.com' (an Online Archive for more storage similar to a PST I guess) and then a shared mailbox 'secondary#domain.com'.
One of the backup folders is in my Online Archive and the other backup folder is a shared mailbox. Here's the VBA code I have so far. Ideally I would like it to run each time an email is sent/appears in the Sent Items so I think I could use WithEvents somehow but I am okay to run the macro on an as needed basis.
When I run the code none of the mail moves so I think the issue is something with how I am selecting the filtered mail items to move.
Sub MoveItems()
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim mySource As Outlook.MAPIFolder
Dim myDestFolder As Outlook.MAPIFolder
Dim myItems As Outlook.Items
Dim myItem As Object
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set mySource = myNameSpace.GetDefaultFolder(olFolderSentMail)
Set myItems = mySource.Items
Set myDestFolder = Outlook.Session.Folders("Online Archive - main#domain.com").Folders("Backup")
Set myItem = myItems.Find("[SenderEmailAddress] = 'main#domain.com'")
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend
Set myItem = myItems.Find("[SenderEmailAddress] = 'secondary#domain.com'")
Set myDestFolder = Outlook.Session.Folders("secondary#domain.com").Folders("SecondaryBackup")
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend
End Sub
Sub MoveItems()
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim mySource, myDestFolder As Outlook.MAPIFolder
Dim myItems As Outlook.Items
Dim myItem As Object
Dim strFilter As String
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set mySource = myNameSpace.GetDefaultFolder(olFolderSentMail)
Set myItems = mySource.Items
strFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:fromname" & Chr(34) & " like '%Main Display Name%'"
Set myDestFolder = Outlook.Session.Folders("Online Archive - main#domain.com").Folders("Backup")
Set myItem = myItems.Find(strFilter)
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend
strFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:fromname" & Chr(34) & " like '%Shared Box Display Name%'"
Set myDestFolder = Outlook.Session.Folders("Shared Box Display Name").Folders("Backup")
Set myItem = myItems.Find(strFilter)
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend
End Sub
You may change to senderName if senderEmailAddress is not in SMTP format.
Sub MoveItems_senderName()
Dim mySource As Folder
Dim myDestFolder As Folder
Dim myItems As Items
Dim myItem As Object
Set mySource = Session.GetDefaultFolder(olFolderSentMail)
'mySource.Display
Set myItems = mySource.Items
Set myDestFolder = Session.Folders("Online Archive - main#domain.com").Folders("Backup")
Debug.Print "senderName: " & senderName
Set myItem = myItems.Find("[SenderName] = 'text from immediate pane'")
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend
End Sub
Related
This script will move email from Joe Smith and Wally Gator to the _ALERTS mail box.
It is slow. I think it reads through the whole inbox (which is huge).
Would there be a way to click on the "Unread" filter in Outlook and have the script look at unread emails?
Sub MoveItems()
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myItem As Object
Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
Set myDestFolder = myInbox.Folders("_ALERTS")
Dim varSearchTerm As Variant: For Each varSearchTerm In Array("Joe Smith", "Wally Gator")
Set myItem = myItems.Find("[SenderName] = '" & varSearchTerm & "'")
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend
Next
End Sub
You're looking for the filter item [UNREAD] = {TRUE/FALSE}
Sub MoveItems()
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myItem As Object
Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
Set myDestFolder = myInbox.Folders("_ALERTS")
Dim varSearchTerm As Variant: For Each varSearchTerm In Array("Joe Smith", "Wally Gator")
Set myItem = myItems.Find("[SenderName] = '" & varSearchTerm & "' AND [UNREAD] = TRUE")
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend
Next
End Sub
How can I go through this "indefinite 5-10..." list of senders and delete their messages:
mySenders =" Dan Wilson, Tom Hanks, Alisa Milano, Jessica Alba, Torrid, Captain America"
The code below works for a single sender.
Sub MoveItems()
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myItem As Object
Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
Set myDestFolder = myNameSpace.GetDefaultFolder(olFolderDeletedItems)
'how to loop here?
Set myItem = myItems.Find("[SenderName] = 'Kmart'")
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend
End Sub
little confuse. but to delete msg from multiple sender, Add a Second While .. Wend and modify it to use myItem.Delete
Example:
Tested on Outlook 2010
Option Explicit
Sub DeleteItems()
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myItems As Outlook.Items
Dim myItem As Object
Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
'// loop for each sender
Set myItem = myItems.Find("[SenderName] = 'Dan Wilson'")
While TypeName(myItem) <> "Nothing"
myItem.Delete
Set myItem = myItems.FindNext
Wend
'// Loop Next Sender
Set myItem = myItems.Find("[SenderName] = 'Tom Hanks'")
While TypeName(myItem) <> "Nothing"
myItem.Delete
Set myItem = myItems.FindNext
Wend
Set myItem = myItems.Find("[SenderName] = 'Alisa Milano'")
While TypeName(myItem) <> "Nothing"
myItem.Delete
Set myItem = myItems.FindNext
Wend
' More here
End Sub
You could loop through an an array based on mySenders.
Option Explicit
Sub MoveItems()
Dim myNameSpace As Namespace
Dim myInbox As folder
Dim myDestFolder As folder
Dim myItems As Items
Dim myItem As Object
Dim mySenders() As String
Dim i As Long
Set myNameSpace = GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
Set myDestFolder = myNameSpace.GetDefaultFolder(olFolderDeletedItems)
mySenders = Split("Dan Wilson,Tom Hanks,Alisa Milano,Jessica Alba,Torrid,Captain America", ",")
For i = LBound(mySenders) To UBound(mySenders)
Debug.Print i & " - " & mySenders(i)
Set myItem = myItems.Find("[SenderName] = """ & mySenders(i) & """")
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend
Next
End Sub
You will need the exact names.
Sub display_SenderName()
Dim currItem As Object
Select Case ActiveWindow.Class
Case olExplorer
' The active window is a list of messages (folder)
' There might be several selected messages
' Here only one is processed
Set currItem = ActiveExplorer.Selection(1)
Debug.Print currItem.Subject
Debug.Print currItem.senderName
Case olInspector
Set currItem = ActiveInspector.currentItem
Debug.Print currItem.Subject
Debug.Print currItem.senderName
End Select
End Sub
So I am trying to create a Macro that will search my e-mails based on a piece of information on an access form I know I am close but I cannot seem to figure out the final piece
Private Sub btnEMAIL_Click()
Dim strID As String, strMessages As String
Call Outlook_open 'CHECKS TO SEE IF OUT LOOK IS OPEN
Dim myOlApp As Object
Set myOlApp = CreateObject("Outlook.Application") 'Creates outlook object
strID = PayeeID.Value 'this is a value on the form
Dim myNameSpace As Outlook.Namespace
Dim myInbox As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim myitem As Object
Dim blnfound As Boolean
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.Folders("HQP Field Compensation").Folders("Inbox")
Set myitems = myInbox.Items
Set mySearch = AdvancedSearch(Scope:=myInbox,Filter:="urn:schemas:mailheader:subject= '" & strID & "'")
Set myResults = mySearch.Results
If myResults.Count > 0 Then
For intCounter = 1 To myResults.Count
myResults.Item(intCounter).Display 'Should display the relevant e-mail
Next intCounter
End If
End Sub
AdvancedSearch is asynchronous/ Since you are only searching through the Inbox, use Items.Restrict or Items.Find/FindNext
set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
set myItems = myInbox.Items
set myItem = myItems.Find("[Subject]='" & strID & "'")
while Not (myItem Is Nothing)
myItem.Display
set myItem = myItems.FindNext
wend
I am using the following vba code to get emails from my inbox folder and move them to a sub folder called suppliers. At the moment the emails are moved from my default email inbox, but I have an account called purcashing#hewden.co.uk and I want it to get the emails from this inbox and move it to the subfolder called Suppliers in this account.
can someone show me how I would alter GetDefaultFolder to make this happen. thanks
Sub MoveItems()
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myItem As Object
Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
Set myDestFolder = myInbox.Folders("Supplier")
Set myItem = myItems.Find("[Subject] = 'Introduction'")
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend
End Sub
Instead of using Namespace.GetDefaultFolder, retrieve the appropriate store from the Namespace.Stores collection and use Store.GetDefaultFolder.
I just used Dmitry's suggestion and it works like a charm.
Hope it helps \o/
Sub GetEmailFromNonDefaultInbox()
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim myInbox As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim strFilter As String
' let the user choose which account to use
Set myAccounts = myOlApp.GetNamespace("MAPI").Stores
For i = 1 To myAccounts.count
res = MsgBox(myAccounts.Item(i).DisplayName & "?", vbYesNo)
If res = vbYes Then
Set myInbox = myAccounts.Item(i).GetDefaultFolder(olFolderInbox)
Exit For
End If
Next
If myInbox Is Nothing Then Exit Sub ' avoid error if no account is chosen
' query emails by subject
strFilter = "#SQL=""urn:schemas:httpmail:subject"" like '%YOUR SUBJECT%'"
Set myitems = myInbox.Items.Restrict(strFilter)
' show some feedback if no email is found
If myitems.count = 0 Then
MsgBox "Nothing found. Try another account."
Exit Sub
End If
' get the most recent email
myitems.Sort "ReceivedTime", True
Set myitem = myitems.GetFirst
If myitem.Class = olMail Then
' and now you can do whatever you want
MsgBox (myitem.Subject)
End If
End Sub
I have this code to search in my folder.
I do have a e-mail with the "sketch" subject, but VBA is not finding it (it goes to the ELSE clause)
Can anybody tell what is wrong ?
Set olApp = GetObject(, "Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
Set olItms = olFldr.Items
Set Mail = olItms.Find("[Subject] = ""*sketch*""") 'Tracking
If Not (Mail Is Nothing) Then
'use mail item here
Else
NoResults.Show
End If
Here is a way to do the search using Items Restrict.
This runs fast and you do not need to loop through the items to find the items that match the search criteria.
Sub Search_Inbox()
Dim myOlApp As New Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim filteredItems As Outlook.Items
Dim itm As Object
Dim Found As Boolean
Dim strFilter As String
Set objNamespace = myOlApp.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)
strFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%sketch%'"
Set filteredItems = objFolder.Items.Restrict(strFilter)
If filteredItems.Count = 0 Then
Debug.Print "No emails found"
Found = False
Else
Found = True
' this loop is optional, it displays the list of emails by subject.
For Each itm In filteredItems
Debug.Print itm.Subject
Next
End If
'If the subject isn't found:
If Not Found Then
'NoResults.Show
Else
Debug.Print "Found " & filteredItems.Count & " items."
End If
'myOlApp.Quit
Set myOlApp = Nothing
End Sub
The reason your .Find isn't working is because Items.Find doesn't support the use of wildcards. Items.Find also doesn't support searching partial strings. So to actually find the email, you'd need to remove the wildcards and include the entire string in your search criteria.
So here are your options:
If you know the full subject line you're looking for, modify your code like so:
Set Mail = olItms.Find("[Subject] = ""This Sketch Email""")
If you don't (or won't) know the full subject, you can loop through your inbox folder and search for a partial subject line like so:
Untested
Sub Search_Inbox()
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim myitem As Object
Dim Found As Boolean
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myitems = myInbox.Items
Found = False
For Each myitem In myitems
If myitem.Class = olMail Then
If InStr(1, myitem.Subject, "sketch") > 0 Then
Debug.Print "Found"
Found = True
End If
End If
Next myitem
'If the subject isn't found:
If Not Found Then
NoResults.Show
End If
myOlApp.Quit
Set myOlApp = Nothing
End Sub
Hope that helps!