Alter Code to Mark Email as UNREAD

I got the following code from outlookcode.com. It works great except that the item that is moved into the Voicemail folder is marked as read and I don't want that. I don't see where the code is doing that. I added the line that marks it as unread, but it doesn't work whether I use:

              Item.Read = False

or

              Item.Unread = True

Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
  Dim objAttFld As MAPIFolder
  Dim objInbox As MAPIFolder
  Dim objNS As NameSpace
  Dim strAttFldName As String
  Dim strProgExt As String
  Dim arrExt() As String
  Dim objAtt As Attachment
  Dim intPos As Integer
  Dim I As Integer
  Dim strExt As String

  ' #### USER OPTIONS ####
  ' name of Inbox subfolder containing messages with attachments
  strAttFldName = "Voicemail"
  ' delimited list of extensions to trap
  strProgExt = "wav"

  On Error Resume Next
  Set objNS = Application.GetNamespace("MAPI")
  Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
  Set objAttFld = objInbox.Folders(strAttFldName)
  If Item.Class = olMail Then
    If objAttFld Is Nothing Then
      ' create folder if needed
      Set objAttFld = objInbox.Folders.Add(strAttFldName)
    End If
    If Not objAttFld Is Nothing Then
      ' convert delimited list of extensions to array
      arrExt = Split(strProgExt, ",")
      For Each objAtt In Item.Attachments
        intPos = InStrRev(objAtt.FileName, ".")
        If intPos > 0 Then
          ' check attachment extension against array
          strExt = LCase(Mid(objAtt.FileName, intPos + 1))
          For I = LBound(arrExt) To UBound(arrExt)
            If strExt = Trim(arrExt(I)) Then
              Item.Move objAttFld
              Item.Read = False
              Exit For
            End If
          Next
        Else
          ' no extension; unknown type
          Item.Move objAttFld
        End If
      Next
    End If
  End If

  On Error GoTo 0
  Set objAttFld = Nothing
  Set objInbox = Nothing
  Set objNS = Nothing
  Set objAtt = Nothing
End Sub

Open in new window

LVL 22
Anne TroyEast Coast ManagerAsked:
Who is Participating?

Improve company productivity with a Business Account.Sign Up

x
 
FarWestConnect With a Mentor Commented:
I meant the VBA code will not move email and only categorize it, and when you have category column in Inbox you can see and pay attention to those emails, anyway I've seen in some samples  (not Guessing or crossing fingers) the unread is changed before moving the Item not after so I wish you try  it

             Item.UnRead = True
             Item.Move objAttFld
0
 
Phillip BurtonDirector, Practice Manager and Computing ConsultantCommented:
Item.Unread = True
 
should work, but needs to be followed by
 
Item.Save
0
 
Anne TroyEast Coast ManagerAuthor Commented:
Checking!
0
Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
Anne TroyEast Coast ManagerAuthor Commented:
Arghh. That changed nothing. I am using Outlook 2007--forgot to mention. Also, after altering the code, I shutdown Outlook, reopen and test.

Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
  Dim objAttFld As MAPIFolder
  Dim objInbox As MAPIFolder
  Dim objNS As NameSpace
  Dim strAttFldName As String
  Dim strProgExt As String
  Dim arrExt() As String
  Dim objAtt As Attachment
  Dim intPos As Integer
  Dim I As Integer
  Dim strExt As String

  ' #### USER OPTIONS ####
  ' name of Inbox subfolder containing messages with attachments
  strAttFldName = "Voicemail"
  ' delimited list of extensions to trap
  strProgExt = "wav"

  On Error Resume Next
  Set objNS = Application.GetNamespace("MAPI")
  Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
  Set objAttFld = objInbox.Folders(strAttFldName)
  If Item.Class = olMail Then
    If objAttFld Is Nothing Then
      ' create folder if needed
      Set objAttFld = objInbox.Folders.Add(strAttFldName)
    End If
    If Not objAttFld Is Nothing Then
      ' convert delimited list of extensions to array
      arrExt = Split(strProgExt, ",")
      For Each objAtt In Item.Attachments
        intPos = InStrRev(objAtt.FileName, ".")
        If intPos > 0 Then
          ' check attachment extension against array
          strExt = LCase(Mid(objAtt.FileName, intPos + 1))
          For I = LBound(arrExt) To UBound(arrExt)
            If strExt = Trim(arrExt(I)) Then
              Item.Move objAttFld
              Item.UnRead = True
              Item.Save
              Exit For
            End If
          Next
        Else
          ' no extension; unknown type
          Item.Move objAttFld
        End If
      Next
    End If
  End If

  On Error GoTo 0
  Set objAttFld = Nothing
  Set objInbox = Nothing
  Set objNS = Nothing
  Set objAtt = Nothing
End Sub

Open in new window

0
 
Phillip BurtonDirector, Practice Manager and Computing ConsultantCommented:
Just a guess - Try it in another order:

              Item.UnRead = True
              Item.Save
              Item.Move objAttFld
0
 
Anne TroyEast Coast ManagerAuthor Commented:
No. Sorry. I was keeping my fingers crossed, too. :)
0
 
FarWestCommented:
Since you are using subfolders in Inbox folder to organize emails
 I recommended using categories to organize inbox. This way new messages will be noticed without going to subfolder or using search folders. And you can have multiple categories for the same message if you need
This way I hope you will not face the unread problem :)
0
 
Anne TroyEast Coast ManagerAuthor Commented:
They are voicemails. I simply don't want to miss them. Once I listen to it, I will delete it. Categories seems like overkill?
0
 
Anne TroyEast Coast ManagerAuthor Commented:
I'm sorry. I didn't notice the post until now. Will try tomorrow at work. Thanks so much!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.