Private
Sub
Application_NewMailEx(
ByVal
EntryIDCollection
As
String
)
Dim
arr()
As
String
Dim
i
As
Integer
Dim
ns
As
Outlook.NameSpace
Dim
itm
As
MailItem
Dim
m
As
Outlook.MailItem
Dim
Betreff
As
String
On
Error
Resume
Next
Set
ns = Application.Session
arr = Split(EntryIDCollection,
","
)
For
i = 0
To
UBound(arr)
Set
itm = ns.GetItemFromID(arr(i))
Betreff = m.Subject
If
Len(Betreff) - Len(Replace(Betreff,
"#"
,
""
)) = 2
Then
Betreff = Mid(Betreff, InStr(Betreff,
"#"
) + 1, InStrRev(Betreff,
"#"
) - InStr(Betreff,
"#"
) - 1)
m.Categories = Betreff
m.Save
End
If
Next
End
Sub