Hello,
This free VBA Macro code to automatically Mark incoming emails as read automatically once they
moved to the Junk Email and to the Deleted Folders. The code also can be easily modified to do it
with any other outlook folders.
What this project will do for you in outlook
==============================
Once installed as explained below correctly, all emails moved the Junk Email folder and the deleted folder
will be marked as read automatically. This will make you not bothered about these folder names display
as bold and the number of unread emails in these folders will not also display, so you will forget these folders
except every long time you just empty them.
This macro also will mark emails moved to a folder called "Sales" as Unread, you can create this folder
and create a rule to move specific emails to it say for your orders or sales and will be marked as Unread.
This project is a base code for anyone who can customize to manage Outlook email messages
very easily.
The VBA project consists of 2 source code files:
ThisOutlookSession.cls
mJunkEmailMarkRead.bas
Installation
To install this VBA Macro in your outlook, download the zip file, unzip,
*)-Start your Outlook
*)-Tools->Macros->Visual Basic Editor, or simply just click "ALT+F11", this will start visual basic editor.
*)-In Visual Basic Editor, File->Import File, then select the file ThisOutlookSession.cls from the folder
where you unzipped the package.
*)-Repeat the previous step for the file mJunkEmailMarkRead.bas
You should see these two files now in VBA.
*)-In VB Editor, click on Tools->Digital Signature to create a certificate for the VBA project self signed.
*)-Save this project from the menu File->Save VbaProject.OTM. *)- Make sure the file ThisOutlookSession.cls is imported under the class ThisOutlookSession and not ThisOutlookSession1 or else. Simply just copy the contents of this class file to the ThisOutlookSession created by default under Microsoft Outlook Object.
Now you can close the VB Editor and go back to outlook.
In Outlook, from the Menu Tools->Macros->Security, you may need to set it to low or medium
In Outlook, from the Menu Tools->Macros->Macros..., you should see the macro named JunkEmailMarkRead,
you can click the button Run to test it.
I intentionaly left some other commented code with some links to online resources which could be useful
for others.
File ThisOutlookSession.cls
|
Code: HTML Select All Collapse
|
|
Option Explicit
'--------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------
'http://www.outlookcode.com/article.aspx?id=62
'--------------------------------------------------------------------------------------
' Important
'RE: Outlook Error: The macros in this project are disabled?...
'Make sure when you restart Outlook its no longer running in the system tray or
'running processes list and security is Medium or Low for testing purposes only
' http://www.vbforums.com/showthread.php?t=415518
'--------------------------------------------------------------------------------------
' File location:
' C:\Documents and Settings\mewsoft\Application Data\Microsoft\Outlook\VbaProject.OTM
'--------------------------------------------------------------------------------------
' To find a mail folder path, right click the folder and the folder properties
'--------------------------------------------------------------------------------------
' http://support.microsoft.com/kb/253313
' Security:
'--------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------
'http://65.55.11.235/en-us/library/aa211242(office.11).aspx
'--------------------------------------------------------------------------------------
'HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Outlook\Security
' then add the value AccessVBOM and set it to 1
'--------------------------------------------------------------------------------------
' Outlook Loads at Startup -- Problems
' Remember to disconnect the PDA from the Cradle or USB
' before lunching Outlook
'Do you have a problem with Outlook loading when you boot the computer but it's not in the Start up folder? It's not black magic or ghosts, it's caused another program accessing Outlook's data - this causes Outlook to load.
'If you have a PDA or similar device, don't put it on the cradle or connect it to the computer until you have Outlook open and are ready to sync. If it's not a PDA causing it, look over you list of programs that are loading at start up and see which one uses Outlook data - remove them from start up or disable Outlook integration features.
'If you have a Sony Vaio, a bug in the BIOS loads your default email client at boot. Look on the Sony website for the bios update.
'--------------------------------------------------------------------------------------
' Outlook Command-line switches
' http://office.microsoft.com/en-us/outlook/HP010031101033.aspx
'
'/recycle
'Starts Outlook using an existing Outlook window, if one exists. Used in combination with /explorer or /folder.
' Default created shortcut:
' "C:\Program Files\Microsoft Office\OFFICE11\OUTLOOK.EXE" /recycle
'--------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------
Private WithEvents olInboxItems As Items
Private WithEvents olJunkItems As Items
Private WithEvents olDeletedItems As Items
Private WithEvents olSalesItems As Items
Dim mySalesFolder As Outlook.MAPIFolder
Dim myFolder As Outlook.MAPIFolder
'======================================================================================
Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.Session
' instantiate objects declared WithEvents
Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
Set olJunkItems = objNS.GetDefaultFolder(olFolderJunk).Items
Set olDeletedItems = objNS.GetDefaultFolder(olFolderDeletedItems).Items
'Set myFolder = objNS.GetDefaultFolder(olPublicFoldersAllPublicFolders)
'Set mySalesFolder = objNS.Folders.Item("\\Mail\Sales")
'------------------------------------------------
' This worked
' Sales folder path : \\Mail\Sales
'Set myFolder = objNS.PickFolder
'MsgBox myFolder.Name + " " + myFolder.FolderPath
'------------------------------------------------
Dim objInbox As Outlook.MAPIFolder
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set myFolder = objInbox.Parent.Folders("Sales")
'Set mySalesFolder = objNS.GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders.Item("Sales")
'Set olSalesItems = mySalesFolder.Items
Set olSalesItems = myFolder.Items
'MsgBox "Junk Mail Auto Mark Read Started"
Set objNS = Nothing
End Sub
'======================================================================================
'======================================================================================
Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
On Error Resume Next
'Item.BodyFormat = olFormatPlain
'Item.Save
Set Item = Nothing
End Sub
'======================================================================================
Private Sub olJunkItems_ItemAdd(ByVal Item As Object)
On Error Resume Next
'Item.BodyFormat = olFormatPlain
'Item.Save
'Set Item = Nothing
Debug.Print "Junk item: "; Item.Subject
Item.UnRead = False
Set Item = Nothing
End Sub
'======================================================================================
Private Sub olDeletedItems_ItemAdd(ByVal Item As Object)
On Error Resume Next
'Item.BodyFormat = olFormatPlain
'Item.Save
'Set Item = Nothing
Debug.Print "Deleted item: "; Item.Subject
Item.UnRead = False
Set Item = Nothing
End Sub
Private Sub olSalesItems_ItemAdd(ByVal Item As Object)
On Error Resume Next
'Item.BodyFormat = olFormatPlain
'Item.Save
'Set Item = Nothing
Debug.Print "Sales item: "; Item.Subject
Item.UnRead = True
Set Item = Nothing
End Sub
'======================================================================================
'======================================================================================
'http://www.outlookcode.com/article.aspx?id=62
'Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'
'End Sub
'
'Private Sub Application_NewMail()
'
'End Sub
'
'Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
'
'End Sub
'
'Private Sub Application_OptionsPagesAdd(ByVal Pages As PropertyPages)
'
'End Sub
'
'Private Sub Application_Quit()
'
'End Sub
'
'Private Sub Application_Startup()
'
'End Sub
'Private Sub outApp_NewMailEx(ByVal EntryIDCollection As String)
' Dim mai As Object
' Dim intInitial As Integer
' Dim intFinal As Integer
' Dim strEntryId As String
' Dim intLength As Integer
'
' intInitial = 1
' intLength = Len(EntryIDCollection)
' MsgBox "Collection of EntryIds: " & EntryIDCollection
' intFinal = InStr(intInitial, EntryIDCollection, ",")
' Do While intFinal <> 0
' strEntryId = Strings.Mid(EntryIDCollection, intInitial, (intFinal - intInitial))
' MsgBox "EntryId: " & strEntryId
' Set mai = Application.Session.GetItemFromID(strEntryId)
' MsgBox mai.Subject
' intInitial = intFinal + 1
' intFinal = InStr(intInitial, EntryIDCollection, ",")
' Loop
' strEntryId = Strings.Mid(EntryIDCollection, intInitial, (intLength - intInitial) + 1)
' MsgBox strEntryId
' Set mai = Application.Session.GetItemFromID(strEntryId)
' MsgBox mai.Subject
'
'End Sub
'Dim objFolder As MAPIFolder
'
' For Each objFolder In Application.GetNamespace("MAPI").Session.Session.Folders
'
' 'German
' If objFolder.FolderPath = "\\?ffentliche Ordner" Then
' Set objFolder = objFolder.Folders("Favoriten")
' Exit For
' End If
'
' 'English
' If objFolder.FolderPath = "\\Public Folders" Then
' Set objFolder = objFolder.Folders("Favorites")
'
' Exit For
' End If
' Next
'Function SetFolderType(intCurrentFolderType As Integer) As Long
' ' This uses the Outlook Constants for ItemType and DefaultFolders
' Select Case intCurrentFolderType
' Case Is = 0 ' olMailItem
' SetFolderType = 6
' ' Sets folder type to olFolderInbox, however
' ' it is crucial to note that there are different types of "mail" folders;
' ' see Outlook Constants in the Help file for more info.
' Case Is = 1 ' olAppointmentItem
' SetFolderType = 9
' ' Sets folder type to olFolderCalendar
' Case Is = 2 ' olContactItem
' SetFolderType = 10
' ' Sets folder type to olFolderContacts
' Case Is = 3 ' olTaskItem
' SetFolderType = 13
' ' Sets folder type to olFolderTasks
' Case Is = 4 ' olJournalItem
' SetFolderType = 11
' ' Sets folder type to olFolderJournal
' Case Is = 5 ' olNoteItem
' SetFolderType = 12
' ' Sets folder type to olFolderNotes
' Case Is = 6 ' olPostItem
' SetFolderType = 18
' ' Sets folder type to olPublicFoldersAllPublicFolders
' Case Is = 7 ' olDistributionListItem
' SetFolderType = 10
' ' Sets folder type to olFolderContacts
' End Select
'End Function
'
' Outlook Folders
'olFolderCalendar
'olFolderContacts
'olFolderDeletedItems
'olFolderDrafts
'olFolderInbox
'olFolderJournal
'olFolderJunk
'olFolderNotes
'olFolderOutbox
'olFolderSentMail
'olFolderTasks
'olPublicFoldersAllPublicFolders
'olFolderConflicts
'olFolderLocalFailures
'olFolderServerFailures
'olFolderSyncIssues
'Set ns = GetNamespace("MAPI")
'Set Inbox = ns.GetDefaultFolder(olFolderInbox)
'Set SubFolder1 = Inbox.Folders("Gary")
'Set SubFolder2 = SubFolder1.Folders("Kickabout")
'Set SubFolder3 = SubFolder2.Folders("Attachments")
'
'Public Function GetFolder(strFolderPath As String) As MAPIFolder
' ' strFolderPath needs to be something like
' ' "Public Folders\All Public Folders\Company\Sales" or
' ' "Personal Folders\Inbox\My Folder"
'
' Dim objApp As Outlook.Application
' 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
'
' strFolderPath = Replace(strFolderPath, "/", "\")
' arrFolders() = Split(strFolderPath, "\")
' Set objApp = Application
' Set objNS = objApp.GetNamespace("MAPI")
' 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
' Set objApp = Nothing
'End Function
'==========================================================================
'==========================================================================
'How to Automatically Move Inbox Items With a Blank Subject
'The code in the "How to Enter the Code in the Visual Basic Editor" section of this
'rticle moves any messages that arrive in your Inbox to a subfolder that is named "Temp"
'without quotation marks). After you enter the code, you can assign the Start and Stop
'macros to a toolbar button.
'==========================================================================
' The first two "Dim" statements declare
' global variables, and must be located in
' the "General Declarations" section at
' the beginning of the Code window.
'Dim WithEvents objInboxItems As Outlook.Items
'Dim objDestinationFolder As Outlook.MAPIFolder
'
'' Run this code to start your rule.
'Sub StartRule()
' Dim objNameSpace As Outlook.NameSpace
' Dim objInboxFolder As Outlook.MAPIFolder
'
' Set objNameSpace = Application.Session
' Set objInboxFolder = objNameSpace.GetDefaultFolder(olFolderInbox)
' Set objInboxItems = objInboxFolder.Items
' Set objDestinationFolder = objInboxFolder.Folders("Temp")
'End Sub
'
'' Run this code to stop your rule.
'Sub StopRule()
' Set objInboxItems = Nothing
'End Sub
'
'' This code is the actual rule.
'Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
' If Item.Subject = "" Then
' Item.Move objDestinationFolder
' End If
'End Sub
''=====================================================================================
''=====================================================================================
'Private WithEvents m_colExplorers As Outlook.Explorers
'Private WithEvents m_objExplorer As Outlook.Explorer
'
'Private Sub Application_Startup()
'Dim m_explevents As New ExplEvents
'm_explevents.InitExplorers Application
'm_explevents.m_objExplorer_FolderSwitch
'End Sub
'
'
'Sub Class_Terminate()
'Call DeRefExplorers
'End Sub
'
'Public Sub InitExplorers(objApp As Outlook.Application)
'Set m_colExplorers = objApp.Explorers
'If m_colExplorers.Count > 0 Then
'Set m_objExplorer = objApp.ActiveExplorer
'End If
'End Sub
'
'Public Sub DeRefExplorers()
'Set m_colExplorers = Nothing
'Set m_objExplorer = Nothing
'End Sub
'
'Private Sub m_colExplorers_NewExplorer _
'(ByVal Explorer As Explorer)
'Set m_objExplorer = Explorer
'End Sub
'
'Public Sub m_objExplorer_FolderSwitch()
'Set myOlApp = Application
'Dim olns As Outlook.NameSpace
'Set olns = myOlApp.GetNamespace("MAPI")
'Dim SearchFolder As Outlook.MAPIFolder
'Dim myOlExp As Outlook.Explorer
'Dim vw As Outlook.View
'Set myOlExp = myOlApp.ActiveExplorer
'Set SearchFolder = myOlExp.CurrentFolder
'myType = SearchFolder.DefaultItemType
'Set vw = SearchFolder.CurrentView
'MsgBox myType
'If myType = 0 Then
''Set current view to "By Company"
'If Not vw.Name = "MyView" Then
'myOlExp.CurrentView = "MyView"
'End If
'End If
'Set myOlApp = Nothing
'Set olns = Nothing
'Set SearchFolder = Nothing
'Set myOlExp = Nothing
'Set vw = Nothing
'Set myType = Nothing
'End Sub
'=====================================================================================
'=====================================================================================
'=====================================================================================
'=====================================================================================
'=====================================================================================
|
mJunkEmailMarkRead.bas
|
Code: HTML Select All Collapse
|
|
Public Sub JunkEmailMarkRead()
Dim outApp As Outlook.Application
Dim junkFolder As Outlook.MAPIFolder
Dim junkItem As Object
'Dim entryID As String
Set outApp = CreateObject("outlook.application")
Set junkFolder = outApp.GetNamespace("MAPI").GetDefaultFolder(olFolderJunk)
For Each junkItem In junkFolder.Items
'junkItem.UnRead = True
junkItem.UnRead = False
'entryID = junkItem.entryID ' Store item entry id
'junkItem.Delete ' Delete from junk mail folder
' use junkItem.Remove to permanetly delete the items
' To permanently delete item find and delete from deleted items
'Set deleteItem = outApp.Session.GetItemFromID(entryID)
'deleteItem.Delete
Next
'MsgBox "Marking done ... Messages: " + CStr(junkFolder.Items.Count)
Debug.Print "Marking done ... Messages: " + CStr(junkFolder.Items.Count)
Set junkItem = Nothing
Set junkFolder = Nothing
Set outApp = Nothing
End Sub
'Sub JunkEmailMarkReadX()
'
'Dim oFld As Outlook.MAPIFolder
'
'Set oFld = Application.Session.GetDefaultFolder(olFolderJunk)
'
'Dim Count As Long
'Dim x As Long
'
'With oFld
' Count = .Items.Count
'For x = 1 To Count
'
' .UnReadItemCount
'
'
'Next x
'
''While .Items.Count
''.Items(1).Delete
''Wend
'
'End With
'
'End Sub
'Public Sub EmptyJunkEmailFolder()
'
' Dim outApp As Outlook.Application
' Dim junkFolder As Outlook.MAPIFolder
' Dim junkItem, deleteItem As Object
' Dim entryID As String
'
' Set outApp = CreateObject("outlook.application")
' Set junkFolder = outApp.GetNamespace("MAPI").GetDefaultFolder(olFolderJunk)
'
' For Each junkItem In junkFolder.Items
' entryID = junkItem.entryID ' Store item entry id
' junkItem.Delete ' Delete from junk mail folder
'
' ' To permanently delete item find and delete from deleted items
' Set deleteItem = outApp.Session.GetItemFromID(entryID)
' deleteItem.Delete
' Next
'
' Set junkItem = Nothing
' Set deleteItem = Nothing
' Set junkFolder = Nothing
' Set outApp = Nothing
'
'End Sub
'Public Sub EmptyJunk()
' Do While ActiveExplorer.Session.GetDefaultFolder(olFolderJunk).Items.Count > 0
'
' ActiveExplorer.Session.GetDefaultFolder(olFolderJunk).Items.Remove (1)
'
' Loop
'
' Do While ActiveExplorer.Session.GetDefaultFolder(olFolderDeletedItems).Items.Count > 0
'
' ActiveExplorer.Session.GetDefaultFolder(olFolderDeletedItems).Items.Remove (1)
'
' Loop
'End Sub
'Sub GetSelectedItems()
' Dim myOlApp As New Outlook.Application
' Dim myOlExp As Outlook.Explorer
' Dim myOlSel As Outlook.Selection
' Dim MsgTxt As String
' Dim x As Integer
' MsgTxt = "You have selected items from: "
' Set myOlExp = myOlApp.ActiveExplorer
' Set myOlSel = myOlExp.Selection
' For x = 1 To myOlSel.Count
' MsgTxt = MsgTxt & myOlSel.Item(x).SenderName & ";"
'
' Next x
' MsgBox MsgTxt
'End Sub
'
'Public WithEvents myOlApp As Outlook.Application
'
'Sub Initialize_handler()
' Set myOlApp = CreateObject("Outlook.Application")
'End Sub
'
'Private Sub myOlApp_NewMail()
' Dim myExplorers As Outlook.Explorers
' Dim myFolder As Outlook.MAPIFolder
' Dim x As Integer
' Set myExplorers = myOlApp.Explorers
' Set myFolder = myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
' If myExplorers.Count <> 0 Then
' For x = 1 To myExplorers.Count
' On Error GoTo skipif
' If myExplorers.Item(x).CurrentFolder.Name = "Inbox" Then
' myExplorers.Item(x).Display
' myExplorers.Item(x).Activate
' Exit Sub
' End If
'skipif:
' Next x
' End If
' On Error GoTo 0
' myFolder.Display
'End Sub
|
| 
Quote
