ItemAdd on Imap Folder get endless loop after saving item

[Alex S.]

Hi there

i have a little sub wich check and change the subject.
When it save the subject the ItemAdd Event is firing again and i get an endless loop.
Any ideas what is wrong?

Private Sub yFld_ItemAdd(ByVal item As Object) 
    If Left(item.Subject, 16) Like "Visit from Mail:" And IsNumeric(Mid(item.Subject, 17)) Then 
        NewSubject = "checked: " & item.Subject & " " & newVisit(CLng(Mid(item.Subject, 17))) 
        If item.Subject <> NewSubject Then 
            item.Subject = NewSubject 
            item.Save 
        End If 
    End If 
End Sub

 

[Diane Poremsky]

It's an itemadd sub, so it fires when something is added... or saved. All affected messages have checked: as the first word in the subject? Try this instead: If left(lcase(item.Subject), 8) <> "checked:" Then

I'm not sure why it's failing on the item .subject test in the first line the second time around - I'm pretty sure it's failing on the numeric part in the second If.

This should also work in the second if
If Left(item.Subject, 16) Like "Visit from Mail:" then

 

[Diane Poremsky]

For what it's worth, I tested your macro the best I could (since I don't have the newVisit function) and this works fine, it stops on the item.subject <> newsubject check, as it should. The problem could be with the newVisit function.
Dim NewSubject As String
If Left(item.Subject, 16) Like "Visit from Mail:" And IsNumeric(Mid(item.Subject, 17)) Then
NewSubject = "checked: " & item.Subject & " " & (CLng(Mid(item.Subject, 17)))
If item.Subject <> NewSubject Then

 

[Alex S.]

Hello Diane,
i think the check routine could be everything like len(subject)>1 for testing

You say the in your first post the ItemAdd Event is firing when an item is added/saved.
So in my case i can not change and save an item.sibject without a new ItemAdd Event?

 

[Alex S.]

Let me ask in other words
Why do i see after the edit and save of the item subject a new Mail Item with the changed subject and the "old" MailItem as deleted?
I would expect that the mail is just updated in the subject.

But in reality it makes a copy of the incomming mail with the changed Subject, saves this copy and deletes the original mail.
Has this something to do with the Imap folder?

 

[Alex S.]

Ok, i've got it fixed.
A little bit complicated but "only results count"
I just use a second Folder on my "normal" Inbox to do the changes, so on ItemAdd on the imap folder i only move the mail to my second folder, makes the changes and the move it back to the imap inbox

Private Sub yFld_ItemAdd(ByVal item As Object) 
    If Left(item.Subject, 16) Like "Visit from Mail:" And IsNumeric(Mid(item.Subject, 17)) Then 
        Debug.Print Now & "  -> " & item.Subject 
        x = "checked: " & item.Subject & " " & newVisit(CLng(Mid(item.Subject, 17))) 
        If item.Subject <> x Then 
            Dim oFld As Outlook.MAPIFolder 
            Set oFld = GetFolder("persönliche ordner\posteingang\visit") 
            item.Move oFld 
        End If 
    End If 
End Sub 
Private Sub vFld_ItemAdd(ByVal item As Object) 
    If Left(item.Subject, 16) Like "Visit from Mail:" And IsNumeric(Mid(item.Subject, 17)) Then 
        x = "checked: " & item.Subject & " " & newVisit(CLng(Mid(item.Subject, 17))) 
        Debug.Print Now & "  -> " & x 
        If item.Subject <> x Then 
            item.Subject = x 
            item.Save 
            Dim oFld As Outlook.MAPIFolder 
            Set oFld = GetFolder("info@xxxxxxu\posteingang") 
            item.Move oFld 
        End If 
    End If 
End Sub

NewVisit is a function which is searching in a database and give back some information

The GetFolder Function i use from Sue Mosher

Public Function GetFolder(strFolderPath As String) As Outlook.MAPIFolder 
' 
'  Sue Mosher 
' 
Dim objNS As Outlook.NameSpace 
Dim colFolders As Outlook.Folders 
Dim objFolder As Outlook.MAPIFolder 
Dim arrFolders() As String 
Dim i As Long 
On Error Resume Next 
 
arrFolders() = Split(strFolderPath, "\") 
Set objNS = Application.Session 
Set objFolder = objNS.Folders.item(arrFolders(0)) 
If Not objFolder Is Nothing Then 
    For i = 1 To UBound(arrFolders) 
        Set colFolders = objFolder.Folders 
        Set objFolder = Nothing 
        Set objFolder = colFolders.item(arrFolders(i)) 
        If objFolder Is Nothing Then 
            Exit For 
        End If 
    Next 
End If 
 
Set GetFolder = objFolder 
Set colFolders = Nothing 
Set objNS = Nothing 
End Function

i hope this help others who are looking for a solution

Best Alex