Counting Outlook Subject Line Strings & Create Weekly Averages

[dplmartin]

Hi,

I'm new to VBA and I need help working out how to acheive the followin
task, which involves getting data from Outlook 2007 and the
manipulating it in Excel 2007.

I'm trying to monitor contact form queries coming in from a website
Specifically, how many we are getting on a weekly basis. The email
arrive in my Inbox and once I've confirmed that they've been actioned,
move them into a subfolder called 'Web Forms' for archiving. The subjec
line of the email is determined by the form completed on the website.

I want to create an Excel document that I program with the subject lin
strings to search against. By pressing a button, Excel will go to th
'Web Forms' folder and make a count of the number of times that eac
subject line appears. I also need it to look at the receive dates of th
emails so that it knows how many emails with the same subject line ar
arriving in each week.

The end result is a statement that says "on average, you are receving
number of emails with Y subject line each week".

Obviously as more emails go into the Web Forms folder, the average
will change. I'm happy if the VBA script just discounts the previou
data and collects it afresh.

Thanks for your help.

Domini

 

[Bernie Deitrick]

Dominic,

The macros below require a reference to the Outlook, and were developed using Office 2003, so they
may not work in 2007. I assumed that your Web Forms folder is a sub-folder in your Inbox. It will
currently count only messages less than 7 days old - you can easily modify the code to loop by 7s,
and check dates within ranges....

HTH,
Bernie
MS Excel MVP


Option Compare Text

Sub CountSubjectsInWebForms()
Dim ol As Object
Dim myItem As Outlook.MailItem
Dim myMsg As String
Dim flr As MAPIFolder
Dim myArr() As Variant
Dim myCount As Integer
Dim mySub As Variant
Dim i As Integer
Dim NewSubj As Boolean
Dim iSub As Integer
Dim FldrName As String

FldrName = "Web Forms"

ReDim myArr(1 To 2, 1 To 1)
myArr(1, 1) = ""

Set ol = CreateObject("outlook.application")

Set flr = ol.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set flr = FindFolder(flr, FldrName)
If flr Is Nothing Then
MsgBox "Your folder """ & FldrName & """ was not found"
Exit Sub
End If
For Each myItem In flr.Items
If myItem.ReceivedTime + 7 > Now() Then
If myArr(1, 1) = "" Then
myArr(2, 1) = myItem.Subject
myArr(1, 1) = 1
myCount = 1
Else
NewSubj = True
For i = 1 To myCount
If myItem.Subject = myArr(2, i) Then
NewSubj = False
iSub = i
Exit For
End If
Next i

If NewSubj Then
myCount = myCount + 1
ReDim Preserve myArr(1 To 2, 1 To myCount)

myArr(2, myCount) = myItem.Subject
myArr(1, myCount) = 1
Else
myArr(1, iSub) = myArr(1, iSub) + 1
End If
End If
End If
Next myItem

For i = 1 To myCount
MsgBox """" & myArr(2, i) & """ was received " & myArr(1, i) & " times."
Next i
End Sub

Function FindFolder(ByVal flrParent As MAPIFolder, ByVal szName As String) As MAPIFolder
Dim flr As MAPIFolder
For Each flr In flrParent.Folders
If flr.Name = szName Then
Set FindFolder = flr
Exit Function
Else
Set flr = FindFolder(flr, szName)
If flr Is Nothing Then
' Did not find a folder, continue loop
Else
Set FindFolder = flr
Exit Function
End If
End If
Next flr
End Function