Move email items based on a list of email addresses

Status
Not open for further replies.
Thank you Diane for quickly responding to my query.

Yes, i have two more email accounts configured in outlook. should i replace this line

Set objDestFolder = objNamespace.GetDefaultFolder(olFolderSentMail).Folders("Unwanted")
with
Set Items = GetFolderPath("anil@xxxx.com\SentMail\Unwanted").Items

and add the snippet in ThisOutlookSession with "After adding the function to ThisOutlookSession" from Working with VBA and non-default Outlook Folders
 
Not exactly... replace
Set objDestFolder = objNamespace.GetDefaultFolder(olFolderSentMail).Folders("Unwanted")
with
Set objDestFolder = GetFolderPath("anil@xxxx.com\SentMail\Unwanted")

(and dont forget the getfolderpath function)
 
Thank you Diane.

I am not getting error but all the emails from sent folder are moved to unwanted not just the ones i wanted to move listed in addresses-to-move.txt

any thoughts on it?
 
I had that problem the first time I used it - that's why I added this line
strAddress = ""
' Use semicolon separator if there is more than 1 address

is your address on your list of names?
 
i checked for my address thinking this could be triggering but i didn't find my address at all.

and then i added

strAddress = ";" (tried few times)
strAddress = "" (tried few times)

and ; at the end of all the email addresses in the text file

but still all the email items from sent folder(5666) are moved to unwanted folder(5666).



also just so you know i have added GetRecipientAddress into new module

Public Sub GetRecipientAddress()
'http://slipstick.me/9vjgj
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim obj, objMail As Object
Dim objProp As Outlook.UserProperty
Dim strDomain
Dim Recipients As Outlook.Recipients
Dim recip As String
Dim i
Dim prompt As String
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
On Error Resume Next
For Each obj In Selection
Set objMail = obj
strDomain = ""
Set Recipients = objMail.Recipients
For i = Recipients.count To 1 Step -1
recip$ = Recipients.item(i).Address
' To use only the alias from the x.500 address
' If InStr(1, LCase(recip), "/ou=") Then recip = Right(recip, Len(recip) - InStr(1, LCase(recip), "recipients") - 13)
' Use semicolon separator if there is more than 1 address
If i = 1 Then
strDomain = strDomain & recip
Else
strDomain = strDomain & recip & "; "
End If
Next i
Debug.Print strDomain
' Msgbox strDomain
Set objProp = objMail.UserProperties.Add("Recipient Email", olText, True)
objProp.Value = strDomain
objMail.Save
Err.Clear
Next
Set currentExplorer = Nothing
Set obj = Nothing
Set Selection = Nothing
End Sub



and


added this in thisoutlooksession


Dim WithEvents olSent As Items

Private Sub Application_Startup()
Dim NS As Outlook.NameSpace
Set NS = Application.GetNamespace("MAPI")
Set olSent = NS.GetDefaultFolder(olFolderSentMail).Items
Set NS = Nothing
End Sub
Private Sub olSent_ItemAdd(ByVal Item As Object)
' Fromhttp://slipstick.me/1
Dim objProp As Outlook.UserProperty
Dim strDomain As String
Dim Recipients As Outlook.Recipients
Dim recip As String 'Outlook.Recipient
Dim i
strDomain = ""
Set Recipients = Item.Recipients
For i = Recipients.count To 1 Step -1
recip$ = Recipients.Item(i).Address
'If InStr(1, LCase(recip), "/ou=") Then recip = Right(recip, Len(recip) - InStr(1, LCase(recip), "recipients") - 13)
If i = 1 Then
strDomain = strDomain & recip
Else
strDomain = strDomain & recip & "; "
End If
Next i
Set objProp = Item.UserProperties.Add("Recipient Email", olText, True)
objProp.Value = strDomain
Item.Save
Err.Clear
Set objProp = Nothing
Set Recipients = Nothing
End Sub
 
Getrecipients and the thisoutlooksession macros wont have an effect on the one i posted - you'd need to change it to call getrecipients and the itemadd macro just watches for new items. (It's also watching the default account's sent folder, not the one we're working in.
 
The one I used is attached - it moved 375 messages (of 3700) for these addresses. Before i added the line to clear the recipients string, it moved all, because the string kept growing with each message it processed - eventually, all of the banned named would be found in every message.

The attached macro has a couple of debug.print lines - one with the current item # and the total count, and also for the strAddress value. Ctrl+G will show the immediate window so you can see the values.
alias@gmail.com
alias2@gmail.com
alias@mobilegranny.com
outlook-users@yahoogroups.com
alias@domain.com
alias@outlook.com
 

Attachments

  • MoveMessagesSenderFile-outlookforums.txt
    2.3 KB · Views: 418
...and the last test, with 1 entry on the list... it moved all. Sigh.
 
Sh**.. figured it out. If you add a line break at the end of last entry, it moves all.

This is the problem -

2018-10-16_9-09-49.png
 
ok... this cleans any returns in the string - and you can verify its clean in the immediate window (add a break point after end array so you can see it in the immediate window. The screenshot shows what it looked like with and without the replace line.

Code:
' array from list
  Dim fn As String, ff As Integer, txt As String
    fn = "D:\Documents\addresses-to-move.txt" '< --- .txt file path
    txt = Space(FileLen(fn))
    ff = FreeFile
    Open fn For Binary As #ff
    Get #ff, , txt
    Close #ff
    
    txt = Replace(txt, vbCrLf, "")

Dim arrAddress() As String
  'Use Split function to return a zero based one dimensional array.
  arrAddress = Split(txt, vbCrLf)
  Debug.Print txt
  Debug.Print "<end>"
' end arrray

2018-10-16_10-20-25.png
 
Actually... that might not work with more than one name in the list unless you have commas at the end of each name as its not split yet.... back to the drawing board. :(:(
 
Last edited:
As long as the address doesn't have a space, this will work...

Code:
' array from list
  Dim fn As String, ff As Integer, txt As String
    fn = "D:\Documents\addresses-to-move.txt" '< --- .txt file path
    txt = Space(FileLen(fn))
    ff = FreeFile
    Open fn For Binary As #ff
    Get #ff, , txt
    Close #ff

 
 txt = Replace(txt, vbCrLf, " ")
 txt = Trim(txt)

Dim arrAddress() As String
  'Use Split function to return a zero based one dimensional array.
  arrAddress = Split(txt, " ")
' end arrray


The other option is to clean it like this:

Code:
' array from list
  Dim fn As String, ff As Integer, txt As String
    fn = "D:\Documents\addresses-to-move.txt" '< --- .txt file path
    txt = Space(FileLen(fn))
    ff = FreeFile
    Open fn For Binary As #ff
    Get #ff, , txt
    Close #ff

If Len(txt) <> 0 Then
 If Right$(txt, 2) = vbCrLf Or Right$(txt, 2) = vbNewLine Then
             txt = Left$(txt, Len(txt) - 2)
End If
End If

Dim arrAddress() As String
  'Use Split function to return a zero based one dimensional array.
  arrAddress = Split(txt, vbCrLf)
' end arrray
 
thank you Diane,

i found out that if the caret cursor is at the new line in addresses-to-move.txt text file then all the emails from sent folder will be moved to unwanted.

but if the cursor is at the end of the last email then the whole thing works.

excellent work and thank you very much Diane.
You just made my day.
Thank you again.
 
i just realized, this is in the place - not a problem if there is only one recipient.
' clear the string for the next message
strAddress = ""

it should be after
If obj.Class = olMail Then
 
Hi Diane,

just posting the part of edited code. Please let me know if this is good to go or need changes.

' array from list
Dim fn As String, ff As Integer, txt As String
fn = "C:\Users\Daniel\Desktop\addresses-to-move.txt" '< --- .txt file path
txt = Space(FileLen(fn))
ff = FreeFile
Open fn For Binary As #ff
Get #ff, , txt
Close #ff

If Len(txt) <> 0 Then
If Right$(txt, 2) = vbCrLf Or Right$(txt, 2) = vbNewLine Then
txt = Left$(txt, Len(txt) - 2)
End If
End If


Dim arrAddress() As String
'Use Split function to return a zero based one dimensional array.
arrAddress = Split(txt, vbCrLf)
' end arrray

For intCount = objSourceFolder.Items.count To 1 Step -1

Set obj = objSourceFolder.Items.Item(intCount)

Debug.Print objSourceFolder.Items.count
If obj.Class = olMail Then
' clear the string for the next message
strAddress = ""

Dim Recipients As Recipients
Set Recipients = obj.Recipients
For i = Recipients.count To 1 Step -1
recip$ = Recipients.Item(i).Address

' To use only the alias from the x.500 address
' If InStr(1, LCase(recip), "/ou=") Then recip = Right(recip, Len(recip) - InStr(1, LCase(recip), "recipients") - 13)


' Use semicolon separator if there is more than 1 address
If i = 1 Then
strAddress = recip
Else
strAddress = strAddress & recip & "; "
End If

Next i
Debug.Print strAddress
 
it looks good to me - does it work? That's the proof. :)
 
Hi!

Can you sort several users with in the same domain?

aaa@meosxxxxxxxop.fr
aaa@tri-axxx.com
aaa@neuxxxxort.com
aaa@axxxxk.com
aaa@aaxxxx.org
aaa@mckexxxckson.net
aaa@abaraxxxco.com
aaa@roxxxxen.com
aaa@wbmxxxxn.com
aaa@traxxxxinc.com
aaa@apxxxxd.com
bbb@meosxxxxxxxop.fr
bbb@tri-axxx.com
bbb@neuxxxxort.com
bbb@axxxxk.com
ccc@aaxxxx.org
ccc@mckexxxckson.net
ddd@abaraxxxco.com
eee@roxxxxen.com
fff@wbmxxxxn.com
fff@traxxxxinc.com
gg@apxxxxd.com

instead of listing every email address under the same company?

I have tired to use

*@meosxxxxxxxop.fr
**@tri-axxx.com
***@neuxxxxort.com

It works in gmail and G Suite by Google, and Mozilla Thunderbird. What do is the same rules in Microsoft systems?
 
Sort into different folders by sender domain using Rules? Yes - use either words in email address or words in header, where the words are the domain.

If you want to sort within the inbox or another folder, you need to use vba to get the domains and add to the view.
 
Hi Diane,

I have a huge number of emails in sent items and i am trying to move email items based on email addresses to a new folder.

but i have a huge list of 1400+ email addresses. I am moving manually by search email address and then move the found items in sent folder to a new folder. can this be done through a macro?

Appreciate a reply.

yes it can b e done
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
S Send email via SMTP - use transport rules to add to senders inbox (then rule to move to sent items Exchange Server Administration 1
P move a specified email "From" tag items to a certain folder whenever there is "New Mail" in the inbo Outlook VBA and Custom Forms 5
A Search folder and move the email Outlook VBA and Custom Forms 0
B Outlook 2019 Automatically move email after assigning category Using Outlook 4
J Quick steps delete original email and move reply/sent email to folder Using Outlook 2
F VBA to move email from Non Default folder to Sub folders as per details given in excel file Outlook VBA and Custom Forms 11
S Macro to move “Re:” & “FWD:” email recieved the shared inbox to a subfolder in outlook Outlook VBA and Custom Forms 0
D Move Email with Attachment to Folder Outlook VBA and Custom Forms 3
R List folders in a combo box + select folder + move emails from inbox to that folder + reply to that email Outlook VBA and Custom Forms 1
O On click,I want to change subject line of selected mail and then reply to particular email and move Using Outlook 3
L Making rule to move email to folder from one O365 domain Using Outlook 1
acpete48317 Categorize and move Outlook Email Outlook VBA and Custom Forms 2
S Move email accounts to new laptop Using Outlook 1
Diane Poremsky Create Tasks from Email and move to different Task folders Using Outlook 0
O VBA Move EMail Outlook VBA and Custom Forms 3
P Move email to folder Using Outlook 1
G email returns after running macro to move emails Outlook VBA and Custom Forms 1
C Outlook 2013 - Email Gets Sent - But Does Not Move From Outbox to Sent Box Using Outlook 4
D Move email to same folder as the rest of the conversation Using Outlook 1
G Outlook 2003 I need to move email to folder based on subject, using wild card Using Outlook 0
K Outlook Cached Mode - can't create rules to move email to another mailbox Using Outlook 2
D User cannot move email messages within Outlook Inbox folder and sub-folders. Using Outlook 0
S Rule to move BCC email to a folder Using Outlook 6
B Move Sent Email to archival pst folder and mark as read - HOW TO Outlook VBA and Custom Forms 2
V move read email based on date and sender Outlook VBA and Custom Forms 6
V Move email using the Close event Outlook VBA and Custom Forms 11
H Move Selected emails to Local Drive Outlook VBA and Custom Forms 0
A Outlook 365 (OutLook For Mac)Move "On My Computer" Folder Items From Old To New Mac Computer Using Outlook 3
HarvMan Outlook 365 - Rule to Move an Incoming Message to Another Folder Using Outlook 4
humility36 Cannot move emails to archive - 440 error Outlook VBA and Custom Forms 1
C Trying to move messages between imap accounts/folders Using Outlook 5
M Move command Outlook VBA and Custom Forms 11
C Code to move mail with certain attachment name? Does Not work Outlook VBA and Custom Forms 3
B Move emails from one account to another Outlook VBA and Custom Forms 2
N How to add or delete items to Move dropdown Menu Using Outlook 0
Commodore Unable to move message Using Outlook 3
N Line to move origEmail to subfolder within a reply macro Outlook VBA and Custom Forms 0
C Move or copy from field to field Outlook VBA and Custom Forms 0
T Outlook 365 Move newly created tasks automatically on save. Outlook VBA and Custom Forms 1
NVDon Create new Move To Folder list Outlook VBA and Custom Forms 0
P Print attachments automatically and move the mail to an existing folder called "Ted" Outlook VBA and Custom Forms 4
T Macro to move reply and original message to folder Outlook VBA and Custom Forms 6
F Excel VBA to move mails for outlook 365 on secondary mail account Outlook VBA and Custom Forms 1
J Dopey move - deleted profile Using Outlook 1
GregS Outlook 2016 Move Outlook to new computer? Using Outlook 4
Witzker Macro to move @domain.xx of a Spammail to Blacklist in Outlook 2019 Outlook VBA and Custom Forms 7
G Move tasks up/down todo list by VBA Outlook VBA and Custom Forms 1
S Outlook Macro to move reply mail based on the key word in the subjectline Outlook VBA and Custom Forms 0
Eike Move mails via macro triggered by the click of a button? Outlook VBA and Custom Forms 0
G Cannot Move Autocomplete File to New Computer Using Outlook 15

Similar threads

Back
Top