Move email items based on a list of email addresses

anil kumar

New Member
Outlook version
Outlook 2010 64 bit
Email Account
POP3
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
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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)
 

anil kumar

New Member
Outlook version
Outlook 2010 64 bit
Email Account
POP3
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?
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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?
 

anil kumar

New Member
Outlook version
Outlook 2010 64 bit
Email Account
POP3
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
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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.
 

anil kumar

New Member
Outlook version
Outlook 2010 64 bit
Email Account
POP3

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
...and the last test, with 1 entry on the list... it moved all. Sigh.
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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:

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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
 

anil kumar

New Member
Outlook version
Outlook 2010 64 bit
Email Account
POP3
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.
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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
 

anil kumar

New Member
Outlook version
Outlook 2010 64 bit
Email Account
POP3
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
 

mndphaser

New Member
Outlook version
Outlook 2016 64 bit
Email Account
Exchange Server
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?
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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.
 

misha

Member
Outlook version
Outlook 2016 32 bit
Email Account
Exchange Server 2013
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
 
Top