1. Computer problem? Tech Support Guy is completely free -- paid for by advertisers and donations. Click here to join today! If you're new to Tech Support Guy, we highly recommend that you visit our Guide for New Members.

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

Discussion in 'Software Development' started by gicio, Nov 24, 2003.

Thread Status:
Not open for further replies.
  1. gicio

    gicio Thread Starter

    Joined:
    Oct 23, 2002
    Messages:
    89
    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?






    Code:
    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
    
                '[email protected]
                If currentMailItem.SenderEmailAddress = "[email protected]" Then
                    Call MoveMail(currentMailItem, currentMAPIFolder.Folders.Item("Forum").Folders.Item("GotDotNet").EntryID)
                '[email protected]
                ElseIf currentMailItem.SenderEmailAddress = "[email protected]" Then
                    Call MoveMail(currentMailItem, currentMAPIFolder.Folders.Item("News").Folders.Item("Google.com").EntryID)
                '[email protected]
                ElseIf currentMailItem.SenderEmailAddress = "[email protected]" 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
    
    
     
  2. Rockn

    Rockn

    Joined:
    Jul 29, 2001
    Messages:
    21,334
    It looks like it might be crapping out on mail messages that do not fit any of the criteria you set to move mail to specific folders. Not to mention that there is no condiotion set for an ELSE sitting all by it's lonesome near the bottom of your function.
     
  3. gicio

    gicio Thread Starter

    Joined:
    Oct 23, 2002
    Messages:
    89
    or is this code better:


    Code:
    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)
    
                '[email protected]
                If currentMailItem.SenderEmailAddress = "[email protected]" Then
                    Call MoveMail(currentMailItem, currentMAPIFolder.Folders.Item("Forum").Folders.Item("GotDotNet").EntryID)
                '[email protected]
                ElseIf currentMailItem.SenderEmailAddress = "[email protected]" Then
                    Call MoveMail(currentMailItem, currentMAPIFolder.Folders.Item("News").Folders.Item("Google.com").EntryID)
                '[email protected]
                ElseIf currentMailItem.SenderEmailAddress = "[email protected]" Then
                    Call MoveMail(currentMailItem, currentMAPIFolder.Folders.Item("News").Folders.Item("Pressetext").EntryID)
                '[email protected]
                ElseIf currentMailItem.SenderEmailAddress = "[email protected]" Then
                    Call MoveMail(currentMailItem, currentMAPIFolder.Folders.Item("Forum").Folders.Item("Tutorial Forums").EntryID)
                '[email protected]
                ElseIf currentMailItem.SenderEmailAddress = "[email protected]" Then
                    Call MoveMail(currentMailItem, currentMAPIFolder.Folders.Item("Newsletter").Folders.Item("DerStandard.at").EntryID)
                '[email protected]
                ElseIf currentMailItem.SenderEmailAddress = "[email protected]" 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
    
     
As Seen On
As Seen On...

Welcome to Tech Support Guy!

Are you looking for the solution to your computer problem? Join our site today to ask your question. This site is completely free -- paid for by advertisers and donations.

If you're not already familiar with forums, watch our Welcome Guide to get started.

Join over 733,556 other people just like you!

Thread Status:
Not open for further replies.

Short URL to this thread: https://techguy.org/182030

  1. This site uses cookies to help personalise content, tailor your experience and to keep you logged in if you register.
    By continuing to use this site, you are consenting to our use of cookies.
    Dismiss Notice