VBA: My Outlook VBA rule code does't work :(

[gicio]

Hi!!!

I write some VBA code that doesn't work good.
what the code SHOULD do:

After the send/receive proces the code loop through all messages in the inbox
and move the messages in the right folders (depend on the sender email address).

the problem is that after 3 loops I got a :

Run-time error '13': Type mismatch.


can someone tell me why I get this error?

Option Explicit


    Private Sub Application_NewMail()
        Dim currentNameSpace As NameSpace
        Dim currentMAPIFolder As MAPIFolder
        Dim currentMailItem As MailItem

        Set currentNameSpace = Application.GetNamespace("MAPI")
        Set currentMAPIFolder = currentNameSpace.GetDefaultFolder(olFolderInbox)

        For Each currentMailItem In currentMAPIFolder.Items

            'GotDotNet_Community@microsoft.com
            If currentMailItem.SenderEmailAddress = "GotDotNet_Community@microsoft.com" Then
                Call MoveMail(currentMailItem, currentMAPIFolder.Folders.Item("Forum").Folders.Item("GotDotNet").EntryID)
            'newsalerts-noreply@google.com
            ElseIf currentMailItem.SenderEmailAddress = "newsalerts-noreply@google.com" Then
                Call MoveMail(currentMailItem, currentMAPIFolder.Folders.Item("News").Folders.Item("Google.com").EntryID)
            'newsmail@derStandard.at
            ElseIf currentMailItem.SenderEmailAddress = "newsmail@derStandard.at" Then
                Call MoveMail(currentMailItem, currentMAPIFolder.Folders.Item("Newsletter").Folders.Item("DerStandard.at").EntryID)

            Else

            End If

        Next currentMailItem

        Set currentMAPIFolder = Nothing
        Set currentNameSpace = Nothing
    End Sub


    Private Function MoveMail(currentMailItem As MailItem, strTargFldrID As String) As Boolean
        Dim currentNameSpace As NameSpace
        Dim currentMoveMailItem As MailItem

        Set currentNameSpace = Application.GetNamespace("MAPI")

        On Error GoTo FINISH:
        Set currentMoveMailItem = currentMailItem.Copy
        currentMoveMailItem.Move Destfldr:=currentNameSpace.GetFolderFromID(strTargFldrID)
        currentMailItem.Delete
FINISH:
        MoveMail = CBool(Err.Number)
    End Function

 

[_Jack]

It is likely that one of the messages has properties that you do not expect. To debug do the following.

Download and install OUtlook Spy and check the properties of the 4th email message, it is possible that one of the properties is not as you expect.

You could also go the old fashion debug approach and put msgbox debug prompts throughout your code (e.g., msgbox currentMailItem.SenderEmailAddress , if currentMailItem is nothing then msgbox "nothing", etc)

 

[gicio]

or is this code better now:

Option Explicit


    Private Sub Application_NewMail()
        Dim currentNameSpace As NameSpace
        Dim currentMAPIFolder As MAPIFolder
        Dim currentMailItem As MailItem

        Set currentNameSpace = Application.GetNamespace("MAPI")
        Set currentMAPIFolder = currentNameSpace.GetDefaultFolder(olFolderInbox)

        Dim intIndex As Integer
        For intIndex = currentMAPIFolder.Items.Count To 1 Step -1
            Set currentMailItem = currentMAPIFolder.Items(intIndex)

            'GotDotNet_Community@microsoft.com
            If currentMailItem.SenderEmailAddress = "GotDotNet_Community@microsoft.com" Then
                Call MoveMail(currentMailItem, currentMAPIFolder.Folders.Item("Forum").Folders.Item("GotDotNet").EntryID)
            'newsalerts-noreply@google.com
            ElseIf currentMailItem.SenderEmailAddress = "newsalerts-noreply@google.com" Then
                Call MoveMail(currentMailItem, currentMAPIFolder.Folders.Item("News").Folders.Item("Google.com").EntryID)
            'nachricht@mail.pressetext.com
            ElseIf currentMailItem.SenderEmailAddress = "nachricht@mail.pressetext.com" Then
                Call MoveMail(currentMailItem, currentMAPIFolder.Folders.Item("News").Folders.Item("Pressetext").EntryID)
            'noreply@tutorialforums.com
            ElseIf currentMailItem.SenderEmailAddress = "noreply@tutorialforums.com" Then
                Call MoveMail(currentMailItem, currentMAPIFolder.Folders.Item("Forum").Folders.Item("Tutorial Forums").EntryID)
            'newsmail@derStandard.at
            ElseIf currentMailItem.SenderEmailAddress = "newsmail@derStandard.at" Then
                Call MoveMail(currentMailItem, currentMAPIFolder.Folders.Item("Newsletter").Folders.Item("DerStandard.at").EntryID)
            'system@mail.pressetext.com
            ElseIf currentMailItem.SenderEmailAddress = "system@mail.pressetext.com" Then
                Call MoveMail(currentMailItem, currentMAPIFolder.Folders.Item("News").Folders.Item("Pressetext.com").EntryID)

            Else

            End If

        Next intIndex

        Set currentMAPIFolder = Nothing
        Set currentNameSpace = Nothing
    End Sub


    Private Function MoveMail(currentMailItem As MailItem, strTargFldrID As String) As Boolean
        Dim currentNameSpace As NameSpace
        Dim currentMoveMailItem As MailItem

        Set currentNameSpace = Application.GetNamespace("MAPI")

        On Error GoTo FINISH:
        Set currentMoveMailItem = currentMailItem.Copy
        currentMoveMailItem.Move Destfldr:=currentNameSpace.GetFolderFromID(strTargFldrID)
FINISH:
        MoveMail = CBool(Err.Number)
    End Function

 

[_Jack]

I really do not think it is a straight forward issue with your code. From my experience the problem generally lies in a special condition with the item that you are accessing, where there is a special condition that you need to code around.

That is why I use the brute force approach and imbed a ton of msgbox stmts to see the exact line item it is failing on and then use OutlookSpy to look at the properties of that item. Outlook spy will also allow you to manually run the offending code in the item properties window.

 

[gicio]

;(


sorry I'm new to VBA.



regards,


gicio