Last week, one of my workmates asked me if I could construct an Excel solution to automate a particularly tedious task he had to perform on a daily basis. The task involved opening emails, copying the senders, editing them, and searching for them in Workbooks. If the searches failed, the emails would be flagged as unread and the procedure repeated,
ad nauseum. The idea was to ensure that all the senders were found in the Workbooks.
As an Excel VBA hacker, the only part that was not immediately apparent to me was the method to access the non-default Outlook mailbox in which my workmate was receiving the emails, which totaled around 2/3 hundreds a day. After a few google searches, I found the workaround and managed to construct an Excel add-in that now helps my workmate perform the task with a few clicks.
The first step was to add the Outlook object code library from the Excel VBA IDE by clicking
Tools > References, and then ticking Microsoft Outlook 11.0 Object Library and clicking Ok on the dialogue box. Next, the following procedure was created.
Option Explicit
Sub mainProc()
Application.ScreenUpdating = False
'//////////////////////////////////////////////
' declare the vars
'//////////////////////////////////////////////
Dim Sh As Worksheet
Dim Olapp As Object
Dim Olns As Namespace
Dim Fldr As MAPIFolder
Dim OlMail As Variant
Dim intFinalRow As Integer
Dim i, j, k As Integer
Dim intProgCent As Integer
Dim intTotMails As Integer
Dim strFolderId As String
On Error GoTo Err_Rtn:
strFolderId = "xxx"
Set Sh = ActiveSheet
Set Olapp = New Outlook.Application
Set Olns = Olapp.GetNamespace("MAPI")
Set Fldr = Olns.GetFolderFromID(strFolderId)
intTotMails = Fldr.Items.Count
j = 0
k = 0
frmProgressBar.Show
intFinalRow = Sh.Range("F65536").End(xlUp).Row
For Each OlMail In Fldr.Items
j = j + 1
intProgCent = (j / intTotMails) * 100
With frmProgressBar
.ProgressBar1.Value = intProgCent
.lblPercent = Str(intProgCent) & "%"
End With
If OlMail.UnRead = True Then
For i = 1 To intFinalRow
With Sh
If Trim(.Range("F" & i).Value) = _
Right(Trim(OlMail.SenderName), 9) Then
.Range("A" & i & ":K" & i).Interior.ColorIndex = 17
OlMail.UnRead = False
k = k + 1
Exit For
End If
End With
Next i
End If
DoEvents
Next OlMail
Unload frmProgressBar
MsgBox "Total found " & k
Set Fldr = Nothing
Set Olns = Nothing
Set Olapp = Nothing
Set Sh = Nothing
Application.ScreenUpdating = True
Exit Sub
Err_Rtn:
Unload frmProgressBar
Application.ScreenUpdating = True
MsgBox Err.Description
End Sub
The code is self-explanatory. It loops through all the emails in the folder with id equal to the value of
strFolderId. If an email is not already read, the nine rightmost characters of the sender name are extracted with the inbuilt VBA function
Right() and compared with the values in the 'F' column of the active worksheet. If a match is found, the color of the row of the matched value is changed and the email flagged as read. If no match is found, the code interrogates the next email.
There is also a progress bar and a pop-up dialogue box that displays the total number of matches found at the end of the program execution.
Only one thing needs a bit more explanation. The variable
strFolderId is set to "xxx" in line 24. In fact, the value is a long string that is found by running the following macro in Outlook.
Option Explicit
Sub findFolderId()
Dim Ons As Outlook.NameSpace
Dim Fldr As Outlook.MAPIFolder
On Error Resume Next
Set Ons = Application.GetNamespace("MAPI")
Set Fldr = Ons.PickFolder
Debug.Print Fldr.StoreID
Set Ons = Nothing
Fldr = Nothing
On Error GoTo 0
End Sub
The folder id will be displayed in the Immediate window.
One final note. Since this code implements 'early binding' after manually adding the reference to the Outlook object code library, the application will fail to work if/when the object library is upgraded, as might happen when a newer version of MS Office suite is installed. To preempt this issue, the code should be changed to use 'late binding'. In some future post, that is what I might do.
