Move email items based on a list of email addresses

Outlook version
Outlook 2010 64 bit
Email Account
POP3
#21
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
 
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
#22
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)
 
Outlook version
Outlook 2010 64 bit
Email Account
POP3
#23
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?
 
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
#24
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?
 
Outlook version
Outlook 2010 64 bit
Email Account
POP3
#25
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
 
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
#26
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.
 
Outlook version
Outlook 2010 64 bit
Email Account
POP3
#27
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
#28
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

Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
#30
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
 
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
#31
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
 
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
#32
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:
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
#33
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
 
Outlook version
Outlook 2010 64 bit
Email Account
POP3
#34
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.
 
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
#35
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
 
Outlook version
Outlook 2010 64 bit
Email Account
POP3
#36
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
 

Similar threads

Top