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

[giciorek]

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

[Latem]

what line does the type mismatch refer to?

Latem

[giciorek]

this one:

'GotDotNet_Community@ microsoft.com
If currentMailItem.SenderEmailAddress = "GotDotNet_Community@microsoft.com" Then
Call MoveMail(currentMailItem, currentMAPIFolder.Folders.Item("Forum").Folders.Item("GotDotNet").EntryID)

[giciorek]

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