Modifying Macro MoveAgedMail(2) - use categories & "to" as variable

[mrsadmin]

Hi there,

Diane has been an awesome help answering my questions on her blog series, but I thought I should come and post on the forums, (which are great) as I want to see about doing some more interesting tweaks to this code!

The situation:

I want to use the Macro MoveAgedMail2(with Case, new code) as a way to maintain my accounts (imap, non exchange) I have 5+ accounts which need housekeeping. Running this code is far superior to running "move message" rules as per outlook setup for what we need. I am also implementing it in my "Sent" items folder as a way to keep that maintained, rather than piecing together other custom macros.

This is my code - it works perfectly.

Sub MoveAgedMail2()  
   'source:  http://www.slipstick.com/developer/macro-move-aged-mail/
   'Get the function from http://slipstick.me/qf
 
   'Define outlook objects:
   'removed due to 'submission error, length of post'
   
   'set values
   Set objSourceFolder = GetFolderPath("1 admin\inbox\1 dist\1 dist")
   
  'brevity
    Select Case obj.Class
       Case olMail
           sDate = obj.ReceivedTime
           sAge = 3
                  
       Case olReport
           sDate = obj.CreationTime
           sAge = 10
       Case Else
           GoTo NextItem
     End Select
   
   'Perform logic to determine difference between NOW and the date of the item.
      intDateDiff = DateDiff("d", sDate, Now)
         If intDateDiff > sAge Then
    
  'Use a folder in a different data file
          Set objDestFolder = GetFolderPath("2 OLS\Inbox\9 Sort")
               obj.Move objDestFolder
     
 
'brevity
 
 
NextItem: 
 
Next 
 
'brevity 
 
End Sub

I tried to implement other code found: spiceworks edits

It allows movement based on "Sender" details. I can't get it to work, it defaults always to the last 'move' code:

'If Date is older than 0 days (or today) then apply the following logic
                   If intDateDiff > 0 Then
                   'Define Sender of item
                   strSender = objVariant.SenderName
          If strSender = "Voicemail Sender" Then
               Set obDestFolder = as above
                 objVariant.Move obDestFolder
                       moveOnce = 1
          End If 
 
[I]           'even with my code including moveOnce (or removed) it will always default to here:[/I]
          If moveOnce = 0 Then
               Set objDestFolder = GetFolderPath("2 account\Inbox\9 Sort")
                 objVariant.Move obDestFolder
          End If

What I'd like:

If strRecipient = "email@address.com" Then
               Set objDestFolder = GetFolderPath
                objVariant.Move obDestFolder
         End If
             
        If Item.Categories = "Bus - Accs (Dist)" Then
               Set objDestFolder = GetFolderPath
                   objVariant.Move obDestFolder
                   moveOnce = 1
        End If

Setting up for multiple folder use, is it better to set up a number of Modules & name accordingly: MAMailMain(); MAMailSent() etc, then run a Master macro to call each of them (if the Master macro will run in the ThisOutlookSession) Or is there a more efficient way of setting this up?

Rather than SenderName, as from the 2nd site, I need to use email addresses as some of my senders have 2 emails, 1 autogen notices, 1 personal account, but they both use the same 'name'.

My problem now is that I don't know how to change naming conventions, what can be used (ie: SenderEmail vs SenderName, strRecipient vs strSender) I think its a stumbling block.

I am loving learning VBA. Diane has been a tremendous help and has been remarkably patient with my questions.

Thank you in advance.

MrsAdmin

 

[Diane Poremsky]

use strSender = obj.SenderEmailAddress to get the sender's email address.

once i fixed the variable names so they were correct for my code, the spiceworks sample worked when added to the Case sample.

this needs to match your variables - some of the samples use objVariant, others use obj. This uses item.
If Item.Categories = "Bus - Accs (Dist)" Then

i didn't test the code with categories, but it should work if you use the correct variable.

 

[mrsadmin]

Nearly done! I managed to kill my code this afternoon and have had to recreate it. Here is my current 'final' code (next post). However I am still having 2 issues.

1) The 'Return Receipt (displayed)' receipts are not moving.

Body = This is a Return Receipt for the mail that you sent to

Normal Read Receipts move as do autoresponders.

Body = This is a receipt for the email message you sent to

I have tried this code, and variants of it, to check for the item info but I can't get it to work:

PublicSub GetTypeNamesInbox() 
 
Dim myOlItems As Outlook.Items 
 
Set myOlItems = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items 
 
Dim msg As Object 
 
For Each msg In myOlItems
   Debug.Print TypeName(msg)
   'emails are typename MailItem
   'Meeting responses are typename MeetingItem
   'Delivery receipts are typename ReportItem 
 
Next msg 
 
End Sub

2) I am trying to get the code to work to move files based on "Sent to" (Recipients), this is primarily for my Sent Folder, however it's not working.

How do I tell it to check the sent to emails, not the sent from?

Dim objRecip As Recipient 
 
Set objRecip = obj.Recipients
   If objRecip.Address = "eacc@domain.com" Then
           Set objDestFolder = GetFolderPath("1 \Inbox\1 \1\store")
           obj.Move objDestFolder
              'Add move counter so at the end item wont be moved to two locations
                   moveOnce = 1
   End If

Many thanks

 

[mrsadmin]

Due to posting limitations, this is the full semi-complete code I have.


Once the 2 issues (above) are sorted this is my much spliced code.




Thank you.

 
 
Sub MoveAgedMail_Ven()
   'source:    slipstick_case                   http://bit.ly/N7ND3h
   'source:    spiceworks_multipurpose     http://bit.ly/LBltfb            (as '2)
   'source:    outlookforums_categories    http://bit.ly/1axZ2mT      (as '3)
   'source:    vbaexpress_subjline           http://bit.ly/1nWtjQ3      (as '4)
   
   'Requires: GetFolderPath Function: http://slipstick.me/qf
   
   'Set objSourceFolder = GetFolderPath("1 \Inbox\1 \1")
   'Set objDestFolder = GetFolderPath("2 \Inbox\9 Sort")
       
   Dim objOutlook As Outlook.Application
   Dim objNamespace As Outlook.NameSpace
   Dim objSourceFolder As Outlook.MAPIFolder
   Dim objDestFolder As Outlook.MAPIFolder
   Dim lngMovedItems As Long
   Dim intCount As Integer
   Dim intDateDiff As Integer
   Dim sDate As Date
   Dim sAge As Integer
   Dim obj As Variant
   '2
   Dim moveOnce As Integer
      
   Set objOutlook = Application
   Set objNamespace = objOutlook.GetNamespace("MAPI")
   Set objSourceFolder = GetFolderPath("1 \Inbox\1 \1")
   
 
 
'Use a folder in a different data file
   Set objDestFolder = GetFolderPath("2 \Inbox\9 Sort")

 
 
For intCount = objSourceFolder.Items.Count To 1 Step -1
   Set obj = objSourceFolder.Items.Item(intCount)
       DoEvents
       '2
       moveOnce = 0
       
   Select Case obj.Class
       Case olMail
           sDate = obj.ReceivedTime
           sAge = 7
                    
       Case olMeetingResponseNegative, _
           olMeetingResponsePositive, _
           olMeetingCancellation, olMeetingRequest, _
           olMeetingAccepted, olMeetingTentative
           sDate = obj.ReceivedTime
           sAge = 7
                    
       Case olReport
           sDate = obj.CreationTime
           sAge = 7
       Case Else
           GoTo NextItem
   End Select
        
   intDateDiff = DateDiff("d", sDate, Now)
   If intDateDiff > sAge Then
         
         strSender = obj.SenderEmailAddress
               
       '2
       If strSender = "support@flightsimstore.com" Then
           Set objDestFolder = GetFolderPath("2 \Inbox\9 Sort\support")
           obj.Move objDestFolder
              'Add move counter so at the end item wont be moved to two locations
                   moveOnce = 1
       End If
 
 

 
 

       '3
   If obj.Categories = "Inc: D - FSS" Then
       Set objDestFolder = GetFolderPath("2 \Inbox\9 Sort\Payment")
           obj.Move objDestFolder
               moveOnce = 1
   End If
   
       '4
   If InStr(obj.Subject, "Confirmation") > 0 Then
       Set objDestFolder = GetFolderPath("2 \Inbox\9 Sort\test")
           obj.Move objDestFolder
               moveOnce = 1
   End If
  
   If moveOnce = 0 Then
       Set objDestFolder = GetFolderPath("2 ISS 1 OLS\Inbox\9 Sort")
           obj.Move objDestFolder
   End If
       
       'obj.Move objDestFolder
      
       lngMovedItems = lngMovedItems + 1
   End If
  
 
 
NextItem:
 
 
Next

   ' Display the number of items that were moved.
   MsgBox "Moved " & lngMovedItems & " messages(s)."
   
   Set objDestFolder = Nothing

 
 
End Sub

 

[Diane Poremsky]

To get the sent to address, you need to use the recipient collection - something like this gets the email address.
Dim Recipients As Outlook.Recipients
Dim recip As String 'Outlook.Recipient
Dim i


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

' do whatever
Next i

if all of the report items aren't getting picked up, you may need to look for the actual message classes.

 

[mrsadmin]

Thank you for the reply




I've created a 2nd MoveAgedMail_Sent Macro to run on our sent boxes.


I've copied over everything and added in your code


I'm getting an "object required error" on line

Set Recipients = Item.Recipients

Sub MoveAgedMail_Sent()    'source:    slipstick_case                              http://bit.ly/N7ND3h
   'source:    spiceworks_multipurpose     http://bit.ly/LBltfb            (as '2)
   'source:    outlookforums_categories    http://bit.ly/1axZ2mT      (as '3)
   'source:    vbaexpress_subjline                http://bit.ly/1nWtjQ3      (as '4)
   '('5) From Outlookforums
 
 

 
 

   
   'Requires: GetFolderPath Function: http://slipstick.me/qf
           
   Dim objOutlook As Outlook.Application
   Dim objNamespace As Outlook.NameSpace
   Dim objSourceFolder As Outlook.MAPIFolder
   Dim objDestFolder As Outlook.MAPIFolder
   Dim lngMovedItems As Long
   Dim intCount As Integer
   Dim intDateDiff As Integer
   Dim sDate As Date
   Dim sAge As Integer
   Dim obj As Variant
   '2
   Dim moveOnce As Integer
 
 

   '(5)
   [COLOR=#002E5B]Dim recip As String 'Outlook.Recipient[/COLOR]
   Dim Recipients As Outlook.Recipients
   Dim i
 
 

 
 

       
   Set objOutlook = Application
   Set objNamespace = objOutlook.GetNamespace("MAPI")
   Set objSourceFolder = GetFolderPath("1 admin\Inbox\Sent")
   
   'Use a folder in a different data file
   Set objDestFolder = GetFolderPath("1 admin\Inbox\Sent\zSort")
 
   '(5)
   Set Recipients = Item.Recipients
   For i = Recipients.Count To 1 Step -1
   recip$ = Recipients.Item(i).Address
      DoEvents
       '2
       moveOnce = 0
             
   Select Case obj.Class
       Case olMail
           sDate = obj.ReceivedTime
           sAge = 3
                    
       Case olMeetingResponseNegative, _
           olMeetingResponsePositive, _
           olMeetingCancellation, olMeetingRequest, _
           olMeetingAccepted, olMeetingTentative
           sDate = obj.ReceivedTime
           sAge = 3
                    
       Case olReport
           sDate = obj.CreationTime
           sAge = 3
       Case Else
           GoTo NextItem
   End Select
        
   intDateDiff = DateDiff("d", sDate, Now)
   If intDateDiff > sAge Then
         

  If recip$ = "e1@domain.com" Then
           Set objDestFolder = GetFolderPath("1 admin\Inbox\Sent\730")
           obj.Move objDestFolder
              'Add move counter so at the end item wont be moved to two locations
                   moveOnce = 1
       End If
 
 

 
 

   If moveOnce = 0 Then
       Set objDestFolder = GetFolderPath("1 admin\Inbox\Sent\zSort")
           obj.Move objDestFolder
   End If
       
  lngMovedItems = lngMovedItems + 1
   End If
  
 
 
NextItem:
     Next i
   ' Display the number of items that were moved.
   MsgBox "Moved " & lngMovedItems & " messages(s)."
   
   Set objDestFolder = Nothing

 
 
End Sub

Re: Classes, I've tried using a small macro to get the class on the active item but it refuses to work.


I've also tried: MsgBox Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders.Item(1).Items.Item(1).Class


to no avail.




I know i'm missing something simple, LOL tyia.

 

[Diane Poremsky]

Try

changing Dim Recipients As Outlook.Recipients to

Dim Recipients 'As Outlook.Recipients

object required means either the object is not dim'd as the right kind of object or it's not dim'd at all.

 

[mrsadmin]

Try

changing Dim Recipients As Outlook.Recipients to

Dim Recipients 'As Outlook.Recipients

object required means either the object is not dim'd as the right kind of object or it's not dim'd at all.

When I add " Dim recipients As 'Outlook.recipients " I get a syntax error, and the "Outlook recipients" is then commented out.

I've tried adding the information from the Object Class listings, copying & pasting direct from the popup and I still get errors. Either syntax or "424 object required".

I've tried the following variations:

(yours first)
Dim recips As Outlook.recipients
Dim recip As Outlook.recipient
Set recip = Outlook.recipient
Set recips = Outlook.recipients

Dim recips As Outlook.recipients

Dim recip As Outlook.recipient

Set recip = item.recipient

Set recips = item.recipients

Dim recips As Outlook.recipients

Dim recip As Outlook.recipient

Set recip = mailitem.recipient

Set recips = mailitem.recipients

Dim Recipients 'As Outlook.Recipients

Set Recipients = item.recipient

Dim recips As Outlook.recipients

Dim recip As Outlook.recipient

Set recip = obj.recipient

Set recips = obj.recipients

I don't know what else to try.

Sorry, this must be frustrating for you.

 

[Diane Poremsky]

My mistake - the ' belongs before the As - it looks like you figured that out.

Ok... it looks like you are using Item.Recipients but haven't set Item as an object. Later on you use obj., so item should be changed to obj - but that is not set either.

The code at slipstick uses
For intCount = objSourceFolder.Items.Count To 1 Step -1
Set obj = objSourceFolder.Items.Item(intCount)

 

[mrsadmin]

Ahhhh Diane,

I have no idea how or why, but it is now working. I tweaked a few things and ran the "Sent" & "Inbox" MoveAgedMail line by line together.

I think it may have been I removed your original:

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

Set obj = objSourceFolder.Items.Item(intCount)



(thinking it was for the inbox only as you had added the For i = Recipients.Count To 1 Step -1)

Thank you very much. I have the recipients working!

I am still having 2 issues

1) trying to find a way to get the item.class as per my first post

2) If my recipient goes to folder A, but a Category goes to folder B and an email has both Recip & Cat, then OL has a 'moment' and refuses to move on.

Sub MoveAgedMail_Sent()    'source:    slipstick_case                   http://bit.ly/N7ND3h
   'source:    spiceworks_multipurpose     http://bit.ly/LBltfb            (as '2)
   'source:    outlookforums_categories    http://bit.ly/1axZ2mT      (as '3)
   'source:    vbaexpress_subjline           http://bit.ly/1nWtjQ3      (as '4)
   'source:    recipient info                    http://bit.ly/1eNheZl       (as '5)
 
   'Requires: GetFolderPath Function: http://slipstick.me/qf
       
   Dim objOutlook As Outlook.Application
   Dim objNamespace As Outlook.NameSpace
   Dim objSourceFolder As Outlook.MAPIFolder
   Dim objDestFolder As Outlook.MAPIFolder
   Dim lngMovedItems As Long
   Dim intCount As Integer
   Dim intDateDiff As Integer
   Dim sDate As Date
   Dim sAge As Integer
   Dim obj As Variant
   '2
   Dim moveOnce As Integer
       
   '5
   Dim Recipients As Outlook.Recipients
   Dim i
   
   
   Set objOutlook = Application
   Set objNamespace = objOutlook.GetNamespace("MAPI")
   Set objSourceFolder = GetFolderPath("1 \Inbox\Sent\730")
  
   For intCount = objSourceFolder.Items.Count To 1 Step -1
   Set obj = objSourceFolder.Items.Item(intCount)
     DoEvents
       '2
       moveOnce = 0 
 
'5 
 
Set Recipients = obj.Recipients 
 
For i = Recipients.Count To 1 Step -1 
 
recip = Recipients.Item(i).Address
       DoEvents
       '2
       moveOnce = 0
       Next
     
      Select Case obj.Class
       Case olMail
           sDate = obj.ReceivedTime
           sAge = 0
                  
       Case olMeetingResponseNegative, _
           olMeetingResponsePositive, _
           olMeetingCancellation, olMeetingRequest, _
           olMeetingAccepted, olMeetingTentative
           sDate = obj.ReceivedTime
           sAge = 3
                  
       Case olReport
           sDate = obj.CreationTime
           sAge = 3
       Case Else
           GoTo NextItem
   End Select
      
   intDateDiff = DateDiff("d", sDate, Now)
   If intDateDiff > sAge Then
       
            
       '5
       If recip = "1@mail" Then
           Set objDestFolder = GetFolderPath("1\Inbox\Sent\1dlb")
           obj.Move objDestFolder
              'Add move counter so at the end item wont be moved to two locations
                   moveOnce = 1
       End If
     
       If obj.Categories = "Testing BCC" Or obj.Categories = "Testing Gen" Then
       Set objDestFolder = GetFolderPath("1\Inbox\Sent\2dlb")
           obj.Move objDestFolder
               moveOnce = 1
   End If

   If moveOnce = 0 Then
       Set objDestFolder = GetFolderPath("1\Inbox\Sent\Archiving")
           obj.Move objDestFolder
   End If
     
       'obj.Move objDestFolder
    
       lngMovedItems = lngMovedItems + 1
   End If
 
 
NextItem:
Next
   ' Display the number of items that were moved.
   MsgBox "Moved " & lngMovedItems & " messages(s)."
 
   Set objDestFolder = Nothing 
 
End Sub

 

[Diane Poremsky]

I saw those two were missing too, but thought maybe you were using a different method of 'walking' the message list and left it out. There are other ways - but this one is probably the most efficient.

When a message hits both rules, do you want only the first rule to apply or both? The problem is that the message was already moved, and outlook is confused - it doesn't see moveonce until after the lines process. Instead of using the moveonce count, use Goto NextItem to hop out of the If's and move on to the next one. (You'll need to add to the count before Goto NextItem.)

I'll test the different receipt types and see if i can find something that works.

 

[mrsadmin]

Hi Diane,

I'd want in preference:

1) If Category (move)

2) If Subject (move)

3) If recipient (move)

That way I can move based on Cats, Subjects, projects related, then move based on recipient email.

Based on what you wrote, something like the following??

If InStr(1, obj.Subject, "Login Test", vbTextCompare) Or obj.Category = "Test Login" Then        Set objDestFolder = GetFolderPath("9\Inbox\Sent\2 Test Login")
           obj.Move objDestFolder
            Goto Next
   End If 
 
'this is related to the first if, so joined together, as the proj@mine may have either the subj or the cat as well as the email as a rule base 
 
'this email would be for general proj man emails (ie notices etc, not project related). 
 
If recip = "proj@mine" Then
           Set objDestFolder = GetFolderPath("1\Inbox\Sent\etc")
           obj.Move objDestFolder
              'Add move counter so at the end item wont be moved to two locations
                   moveOnce = 1
       End If 
 
Next item: 
 
'completely unrelated to the above but is still in the sent item folder 
 
next 
 
If recip = "accs@mine" Then
           Set objDestFolder = GetFolderPath("1\Inbox\Sent\accs")
           obj.Move objDestFolder
              'Add move counter so at the end item wont be moved to two locations
                   moveOnce = 1
       End If

thank you

 

[Diane Poremsky]

Re: Modifying Macro MoveAgedMail(2) - use categories & "to" as variable

Yes, that looks about right. Does it work?

- - - Updated - - -

Yes, that looks about right. Does it work?