Looping through items in every folder/sub folder

[jp romano]

Good day - could use some help if any of you have a some time to teach an old dog a new trick.

I have some vba code that is working beautifully in the current/selected folder, but I'm not finding an easy way to get it to loop through EVERY sub folder beneath the selected folder.

This is my first attempt at vba in outlook, and most of what I have has been lifted from web search results and tweaked...

I appreciate any help!

Here's what I have. The object is to find all messages from a particular user, then scrape a few data points (they are ALWAYS in the same place, using same terminology), and dump into a spreadsheet for analysis.



Sub ExtractLangData() On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("mapi")
Dim sl, tl, totalwords, repititions, cms, hundred, uniquewords As String

'uses the current folder…


Set MyFolder = myOlApp.ActiveExplorer.CurrentFolder

' create excel object
Set xlobj = CreateObject("excel.application.14")
xlobj.Visible = True
xlobj.Workbooks.Add
'Set Heading

xlobj.Range("a" & 1).Value = "Source Lang"
xlobj.Range("b" & 1).Value = "Target Lang"
xlobj.Range("c" & 1).Value = "Total Words"
xlobj.Range("d" & 1).Value = "Repetitions"
xlobj.Range("e" & 1).Value = "CMs"
xlobj.Range("f" & 1).Value = "100%"
xlobj.Range("g" & 1).Value = "Unique Words"
xlobj.Range("h" & 1).Value = "Summary"

For i = 1 To MyFolder.Items.Count
'Only accesses messages from certain sender
If InStr(MyFolder.Items(i).SenderEmailAddress, "JROMANO") > 0 Then

Set myitem = MyFolder.Items(i)
msgtext = myitem.Body

'search for specific text
sl = Split(msgtext, "Source Language: ")(1)
sl = Split(sl, "Target Language:")(0)
'remove to prevent dupe
msgtext = Replace(msgtext, sl, "sl")

tl = Split(msgtext, "Target Language: ")(1)
tl = Split(tl, "Total Words")(0)
'remove to prevent dupes
msgtext = Replace(msgtext, tl, "tl")

totalwords = Split(msgtext, "Total Words:")(1)
totalwords = Split(totalwords, "Repetition")(0)
'remove to prevent dupe
msgtext = Replace(msgtext, totalwords, "tt")
repititions = Split(msgtext, "Repetitions: ")(1)
repititions = Split(repititions, "CMs")(0)
'remove to prevent dupe
msgtext = Replace(msgtext, repititions, "rr")

cms = Split(msgtext, "CMs: ")(1)
cms = Split(cms, "100")(0)
'remove to prevent dupe
msgtext = Replace(msgtext, cms, "cc")

hundred = Split(msgtext, "100%: ")(1)
hundred = Split(hundred, "Unique Words:")(0)
'remove to prevent dupe
msgtext = Replace(msgtext, hundred, "hh")

uniquewords = Split(msgtext, "Unique Words: ")(1)
'remove to prevent dupe
msgtext = Replace(msgtext, uniquewords, "uu")

'write to excel
sl = Replace(sl, vbCrLf, "")
tl = Replace(tl, vbCrLf, "")
totalwords = Replace(totalwords, vbCrLf, "")
repititions = Replace(repititions, vbCrLf, "")
cms = Replace(cms, vbCrLf, "")
hundred = Replace(hundred, vbCrLf, "")
uniquewords = Replace(uniquewords, vbCrLf, "")

Dim lrow As Integer
lrow = xlobj.Range("A500000").End(xlup).Offset(1, 0).Row

xlobj.Range("a" & lrow).Value = Trim(sl)
xlobj.Range("b" & lrow).Value = Trim(tl)
xlobj.Range("c" & lrow).Value = Trim(totalwords)
xlobj.Range("d" & lrow).Value = Trim(repititions)
xlobj.Range("e" & lrow).Value = Trim(cms)
xlobj.Range("f" & lrow).Value = Trim(hundred)
xlobj.Range("g" & lrow).Value = Trim(uniquewords)
xlobj.Range("h" & lrow).Value = Trim(myitem)


'clear variables
totalwords = ""
repititions = ""
cms = ""
hundred = ""
uniquewords = ""
myitem = ""
End If

Next
End Sub

[jp romano]

marking as solved so nobody wastes time on it - requirements have changed.
Thanks for your time

[skatonni]

You may still be interested in using restrict to reduce processing time and recursion will surely be needed sometime.


Option Explicit
Const searchName = "from DebugPrint_senderemailaddress"
Private Sub DebugPrint_senderemailaddress()
Debug.Print ActiveExplorer.Selection(1).senderemailaddress
End Sub

Sub ExtractDataRecursively()

Dim myNameSpace As Namespace
Dim myFolder As Folder
Dim colItems As Items
Dim colFilteredItems As Items

Dim i As Long

' uses the current folder
Set myNameSpace = GetNamespace("mapi")
Set myFolder = ActiveExplorer.CurrentFolder


Set colItems = myFolder.Items
' Restrict allows faster processing than Instr.
Set colFilteredItems = colItems.Restrict("[senderemailaddress] = '" & searchName & "'")

For i = 1 To colFilteredItems.count
Debug.Print colFilteredItems(i).senderemailaddress
Debug.Print colFilteredItems(i).Subject
Next

LoopFolders myFolder.Folders, True

ExitRoutine:
Set myNameSpace = Nothing
Set myFolder = Nothing
Set colItems = Nothing
Set colFilteredItems = Nothing
End Sub


http://www.vboffice.net/en/developers/looping-recursively-through-folders-and-subfolders/


Public Sub LoopFolders(Folders As Folders, ByVal Recursive As Boolean)

Dim myFolder As Folder
Dim colItems As Items
Dim colFilteredItems As Items
Dim i As Long
For Each myFolder In Folders

Set colItems = myFolder.Items
Set colFilteredItems = colItems.Restrict("[senderemailaddress] = '" & searchName & "'")

For i = 1 To colFilteredItems.count
Debug.Print colFilteredItems(i).senderemailaddress
Debug.Print colFilteredItems(i).Subject
Next
If Recursive Then
LoopFolders myFolder.Folders, Recursive
End If

Next

End Sub

[jp romano]

Skatonni - thank you for the code you provided... I'm not really sure what it's doing, but have every intention on playing around with it and reusing it where I can! Thanks again, and have a great day.