Run Time Error 438

[Evil Red Smurf]

Hi,

I use VBA quite a lot but I wouldn't say I'm an expert - I have a limited "vocabulary" and work around that with help from MrExcel.com

I have an outlook vba macro that I've been using for some time to help file the items in my inbox and it worked fine, however the other day it started coming up with a Run Time Error 438 in the code below. Basically what the macro does is look at each item in my inbox and if the item is marked as complete (with a tick) AND it's received more than 5 days ago then it will file the item in 1 or more folder depending on the categories assigned to the item. The code is as follows(note - I've removed a big chunk from the middle to keep it short, but it's basically the If statement duplicated many times):

Sub MoveToFolder()
Dim ns As Outlook.NameSpace
Dim objItem As Object
Dim FolderInbox As Folder
Dim MyItem As Outlook.MailItem
Dim cMails As Collection

Set ns = Application.GetNamespace("MAPI")Set FolderInbox = ns.GetDefaultFolder(olFolderInbox)Set cMails = New Collection

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

For Each objItem In FolderInbox.Items
If objItem.FlagStatus = 1 And objItem.ReceivedTime < Now - 5 Then                 '''''ERROR IS HERE'''''''''''

     If InStr(objItem.Categories, "ACC") > 0 Then                                            '''          
     Set MyItem = objItem.Copy                                                               '''    This section is duplicated many times with different categories          
     MyItem.Move FolderInbox.Folders("ACC")                                                  '''    being copied to different folders
     cMails.Add objItem.EntryID                                                              '''     
     Else                                                                                    '''
     End If                                                                                  '''    

     objItem.Delete

Else
End If 
Next

On Error Resume Next
Do While cMails.Count > 0
Set MyItem = ns.GetItemFromID(cMails(1))

If Not MyItem Is Nothing Then     
MyItem.Delete
End If

cMails.Remove (1)
Loop
End Sub

As I said, the macro worked fine until just the other day and now it comes up with an error everytime the macro in called.

Any help is greatly appreciated.

Many thanks in advance

Evil Red Smurf

 

[Andrew Poulsom]

What type of item is objItem when you get the error?

 

[Evil Red Smurf]

It's an email in my inbox

 

[RoryA]

I suspect it is not actually an email. Try this version:

Sub MoveToFolder()
   Dim ns                          As Outlook.NameSpace
   Dim objItem                     As Object
   Dim FolderInbox                 As Folder
   Dim MyItem                      As Outlook.MailItem
   Dim cMails                      As Collection

   Set ns = Application.GetNamespace("MAPI")
   Set FolderInbox = ns.GetDefaultFolder(olFolderInbox)
   Set cMails = New Collection

   ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

   For Each objItem In FolderInbox.Items
      If TypeOf objItem Is MailItem Then
         If objItem.FlagStatus = 1 And objItem.ReceivedTime < Now - 5 Then                 '''''ERROR IS HERE'''''''''''

            If InStr(objItem.Categories, "ACC") > 0 Then                                            '''
               Set MyItem = objItem.Copy                                                               '''    This section is duplicated many times with different categories
               MyItem.Move FolderInbox.Folders("ACC")                                                  '''    being copied to different folders
               cMails.Add objItem.EntryID                                                              '''
            Else                                                                                    '''
            End If                                                                                  '''

            objItem.Delete

         Else
         End If
      End If
   Next

   On Error Resume Next
   Do While cMails.Count > 0
      Set MyItem = ns.GetItemFromID(cMails(1))

      If Not MyItem Is Nothing Then
         MyItem.Delete
      End If

      cMails.Remove (1)
   Loop
End Sub

 

[Evil Red Smurf]

That's perfect - you are a star!

something so simple making all the difference.

Many thanks

Evil Red Smurf