Split the subject line to export into separate columns in Excel - vba

I have code which exports the subject of emails from a folder I choose to an Excel workbook. I need the text after the first 'space' in the subject to be exported to another column (column C preferably). Below are a couple of examples of what the subject lines look like:
" 321-654321 APPROVED With more words to follow "
and
" APR#987-123456 CONTIGENT With More text to follow "
I want to have the number (or) everything before the first space in the subject in one column and everything after the number, first space, in a different column.
here is an example of the output I would like to have
Column A - Column B - Column C
XXX-XXXXX - DateOf Email - Status of the incident
Here is the code I'm currently using, I believe I found this macro on Stackoverflow. Also, Can't I skip having the user choose the folder and put what folder I want this macro to act on inside the code?
Sub ExportToExcel()
On Error GoTo ErrHandler
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.Namespace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
strSheet = "spreadhsheet.xlsx"
strPath = "C:\MyOutlookMacro\"
strSheet = strPath & strSheet
Debug.Print strSheet
'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
End If
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Copy field items in mail folder.
For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
intRowCounter = intRowCounter + 3
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Subject
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SentOn
Next itm
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
ErrHandler: If Err.Number = 1004 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
Else
MsgBox Err.Number & "; Description: ", vbOKOnly, "Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub
-------------------------------
Sub ExportToExcel()
On Error GoTo ErrHandler
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
Dim Words As String
strSheet = "spreadhsheet.xlsx"
strPath = "C:\MyOutlookMacro\"
strSheet = strPath & strSheet
Debug.Print strSheet
'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
'Set fld = Set fld = myNamespace.GetDefaultFolder(olFolderInbox).Folders("SpreadsheetItems")
'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
End If
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Copy field items in mail folder.
For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
Words = Split(msg.Subject, " ")
intRowCounter = intRowCounter + 3
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = Words(0)
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SentOn
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = Words(2)
Next itm
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
ErrHandler: If Err.Number = 1004 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
Else
MsgBox Err.Number & "; Description: ", vbOKOnly, "Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub
** I'm getting "Compile Error: Expected Array # rng.Value = Words(0) **

Re: Split the subject
Use Split
Dim Words() As String ' not Dim Words as String
For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
Words = Split(msg.Subject, " ")
intRowCounter = intRowCounter + 3
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = Words(0)
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SentOn
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = Words(2)
Next itm
Re: "... skip having the user choose the folder and put what folder I want ..."
If the Source folder is in the default Inbox then
Set fld = myNamespace.GetDefaultFolder(olFolderInbox).Folders.("Source")
Add as many .Folders("...") as necessary if the Source folder is deeper.
If the Source folder is not in the default Inbox then Get reference to additional Inbox

Related

Count Outlook emails by Sender & date in Excel VBA

The objective is to find the total/count of emails from Sender on Monthly basis.
The below code retrieves Date/Time for a count by month.
How to display by SenderName on the worksheet?
I'm not sure if I've to use two dictionaries? If yes no knowledge about how to work around it.
Sub ReferSpecificFolder()
'Declare Outlook application & folder object variables.
Dim objOutlook as Object, objnSpace as Object, objFolder As Outlook.MAPIFolder
Dim olItem As Variant 'Object
Dim dictDate as Object
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace=objOutlook.GetNamespace("MAPI")
Set objFolder = objOutlook.GetNamespace("MAPI").Folders("xyz#microsoft.com").Folders("Sales - 2020")
Set dictDate=CreateObject("Scripting.Dictionary")
Set myItems = objFolder.Items
On Error Resume Next
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder!"
Exit Sub
End If
If fldr.Items.Count = 0 Then
MsgBox "There were no messages found in your folders"
Exit Sub
End If
'Select the sheet to enter the data
Dim wbData As Worksheet
Dim LastRow As Long
Set wbData = ThisWorkbook.Sheets("Rawdata - Time Period")
LastRow = wbData.Range("A" & wbData.Rows.Count).End(xlUp).Row + 1
myItems.SetColumns("SenderName, SentOn")
For Each i In myItems
dateStr=GetDate(i.SentOn)
strSender=i.SenderName
If Not dictDate.Exists(dateStr) Then
dictDate(dateStr)=0
End If
dictDate(dateStr)=CLng(dictDate(dateStr))+1
Next i
For Each o In dictDate.keys
LastRow = wbData.Range("A" & wbData.Rows.Count).End(xlUp).Row + 1
With wbData
.Cells(LastRow, 1) = o 'Received Date
.Cells(LastRow, 3) = dictDate(o) 'Count
End With
Next o
Set fldr = Nothing
Set olItem = Nothing
Set olApp = Nothing
MsgBox "DONE!"
End Sub
Function GetDate(dt as Date) as String
GetDate=Year(dt) & "-" & Month(dt) & "-" & Day(dt) & " " & Hour(dt) & ":" & Minute(dt)
End Function
This generates a single sender dictionary then a date dictionary corresponding to each entry in the sender dictionary.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
'
' If desperate declare as Variant
'
Sub ReferSpecificFolderSender()
' Early binding, must set a reference to
' Microsoft Outlook XX.X Object Library
Dim objOutlook As Outlook.Application
Dim objnSpace As Outlook.Namespace
Dim objFolder As Outlook.Folder
Dim olItemI As Object
Dim olItemJ As Object
Dim myItems As Outlook.Items
Dim myItemsDate As Outlook.Items
Dim strFilter As String
Dim dictDate As Object
Dim o As Variant
Dim dateStr As String
Dim dictSender As Object
Dim p As Variant
Dim strSender As String
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
' For the specific purpose of addressing an expected error
' due to not finding objFolder
On Error Resume Next
Set objFolder = objnSpace.Folders("xyz#microsoft.com").Folders("Sales - 2020")
If Err.Number <> 0 Then
Err.Clear
'MsgBox "No such folder!"
'Exit Sub
Set objFolder = objnSpace.PickFolder
If objFolder Is Nothing Then Exit Sub
End If
' Consider mandatory to closely follow On Error Resume Next
' Return to normal error handling
On Error GoTo 0
Set myItems = objFolder.Items
Debug.Print vbCr & "myItems.Count: " & myItems.Count
If objFolder.Items.Count = 0 Then
MsgBox "There were no messages found in " & objFolder.FolderPath
Exit Sub
End If
Set dictSender = CreateObject("Scripting.Dictionary")
' Restrict to mailitems
' 0x001A001F
' https://stackoverflow.com/questions/61793354/delete-items-in-outlook-by-type-or-message-class
'strFilter = "#SQL=""http://schemas.microsoft.com/mapi/proptag/0x001A001F"" LIKE 'IPM.Note'"
'Set myItems = myItems.Restrict(strFilter)
' 0x001A001E
' "PR_MESSAGE_CLASS" http://schemas.microsoft.com/mapi/proptag/0x001A001E
' https://www.slipstick.com/developer/read-mapi-properties-exposed-outlooks-object-model/
strFilter = "#SQL=""http://schemas.microsoft.com/mapi/proptag/0x001A001E"" LIKE 'IPM.Note'"
Set myItems = myItems.Restrict(strFilter)
Debug.Print vbCr & "Mailitems"
Debug.Print "myItems.Count: " & myItems.Count
myItems.Sort "[SenderName]", False
Set dictDate = CreateObject("Scripting.Dictionary")
Set myItemsDate = myItems
Debug.Print "myItemsDate.Count: " & myItemsDate.Count
'The sheet to enter the data
Dim wbData As Worksheet
Dim LastRow As Long
Set wbData = ThisWorkbook.Sheets("Rawdata - Time Period")
LastRow = wbData.Range("A" & wbData.Rows.Count).End(xlUp).Row + 1
' dictionary of sender names
Debug.Print "Sender dictionary"
' With the SetColumns method, Outlook only checks the properties that you have cached,
' and provides fast, read-only access to these properties.
' https://learn.microsoft.com/en-us/office/vba/api/outlook.items.setcolumns
myItems.SetColumns ("SenderName")
For Each olItemJ In myItems
strSender = olItemJ.SenderName
If Not dictSender.Exists(strSender) Then
Debug.Print " " & strSender
dictSender(strSender) = 0
End If
dictSender(strSender) = CLng(dictSender(strSender)) + 1
Next
' iterate unique sender names
For Each p In dictSender.keys
Debug.Print "Date dictionary for: " & p
myItems.Sort "[SentOn]", False
myItemsDate.SetColumns ("SenderName, SentOn")
' check item's date against the sender name dictionary
For Each olItemI In myItemsDate
strSender = olItemI.SenderName
If strSender = p Then
' unique dates for current SenderName
dateStr = GetDate(olItemI.SentOn)
If Not dictDate.Exists(dateStr) Then
dictDate(dateStr) = 0
End If
' count of ccurrences for each date
dictDate(dateStr) = CLng(dictDate(dateStr)) + 1
End If
Next
For Each o In dictDate.keys
LastRow = wbData.Range("A" & wbData.Rows.Count).End(xlUp).Row + 1
With wbData
.Cells(LastRow, 1) = p ' SenderName
.Cells(LastRow, 2) = o ' GetDate value
.Cells(LastRow, 3) = dictDate(o) ' Count
End With
Next
' delete date dictionary entries for current SenderName
dictDate.RemoveAll
Next p
ActiveSheet.Columns.AutoFit
Set objFolder = Nothing
Set olItemI = Nothing
Set olItemJ = Nothing
Set objOutlook = Nothing
Set objnSpace = Nothing
Set dictSender = Nothing
Set dictDate = Nothing
Set myItemsDate = Nothing
Debug.Print "DONE!"
'MsgBox "DONE!"
End Sub

Error 438 when using GetConversation on a mail item

I'm trying to export all e-mails in a shared inbox to excel. I'm specifically interested in how many conversations I've had, rather than all e-mails I've received.
I'm getting the 438 error on the Set conv = Item.GetConversation() line:
Object doesn't support this property or method.
This implies that Item doesn't support GetConversation, even though it is a function for a MailItem.
Public Sub ExportToExcel()
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim SubFolder As Object
Dim MailFolder As Object
Dim SharedInbox As Outlook.MAPIFolder
Dim objRecip As Outlook.Recipient
Dim Item As Object
Dim conv As Object
Dim store As Outlook.Store
Dim xlApp As New Excel.Application
Dim xlWB As Excel.Workbook
Dim i As Long
Dim ArrHeader As Variant
On Error GoTo MsgErr
Set objOL = Application
Set objNS = objOL.GetNamespace("MAPI")
Set objRecip = objNS.CreateRecipient("sharedmailbox#outlook.com")
Set SharedInbox = objNS.GetSharedDefaultFolder(objRecip, olFolderInbox)
Set MailFolder = SharedInbox.Folders("Archive").Folders("Sub")
ArrHeader = Array("Category", "Date Sent", "Subject", "Mails in conversation")
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add
xlWB.Worksheets(1).Range("A1").resize(1, UBound(ArrHeader) + 1).Value = ArrHeader
For Each SubFolder In MailFolder.Folders
For Each Item In SubFolder.Items
If (Item.Class = olMail) Then
store = SubFolder.store
If (store.IsConversationEnabled) Then
Set conv = Item.GetConversation()
If (conv <> Null) Then
xlWB.Worksheets(1).Cells(i + 1, "A").Value = SubFolder.Name
xlWB.Worksheets(1).Cells(i + 1, "B").Value = Item.ReceivedTime
xlWB.Worksheets(1).Cells(i + 1, "C").Value = Item.Subject
xlWB.Worksheets(1).Cells(i + 1, "D").Value = conv.GetTable().getrows()
End If
End If
End If
Next Item
Next SubFolder
xlWB.Worksheets(1).Cells.EntireColumn.Autofit
MsgErr_Exit:
Set emailSourceFolder = Nothing
Set emailDestFolder = Nothing
Set objNS = Nothing
Set objOL = Nothing
Set SubFolder = Nothing
Set MailFolder = Nothing
Set SharedInbox = Nothing
Set objRecip = Nothing
Set Item = Nothing
Set conv = Nothing
Set Store = Nothing
Set xlWB = Nothing
Set xlApp = Nothing
Set i = Nothing
Set ArrHeader = Nothing
Exit Sub
'// Error information
MsgErr:
MsgBox "An unexpected Error has occurred." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MsgErr_Exit
End Sub

MS-Word 2010 - Macro to export table to Outlook Tasks

I'm trying to create a macro in MS-Word VBA to take the contents of a MS-Word table (with a bookmarked name), iterate through the rows of the table and create tasks in MS-Outlook (1 row=1 task).
I have Googled and think I will need to try and mix together the following two scripts I have found:
Script 1 - (For making calendar entries - not wanted, but iteration through rows - wanted)
Sub AddAppntmnt()
'Adds a list of events contained in a three column Word table
'with a header row, to Outlook Calendar
Dim olApp As Object
Dim olItem As Object
Dim oTable As Table
Dim i As Long
Dim bStarted As Boolean
Dim strStartDate As Range
Dim strEndDate As Range
Dim strSubject As Range
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set olApp = CreateObject("Outlook.Application")
bStarted = True
End If
Set oTable = ActiveDocument.Tables(1)
'Ignore the first (header) row of the table
For i = 2 To oTable.Rows.Count
Set strStartDate = oTable.Cell(i, 1).Range
strStartDate.End = strStartDate.End - 1
Set strEndDate = oTable.Cell(i, 2).Range
strEndDate.End = strEndDate.End - 1
Set strSubject = oTable.Cell(i, 3).Range
strSubject.End = strSubject.End - 1
Set olItem = olApp.CreateItem(1)
olItem.Start = strStartDate
olItem.End = strEndDate
olItem.ReminderSet = False
olItem.AllDayEvent = True
olItem.Subject = strSubject
olItem.Categories = "Events"
olItem.BusyStatus = 0
olItem.Save
Next i
If bStarted Then olApp.Quit
Set olApp = Nothing
Set olItem = Nothing
Set oTable = Nothing
End Sub
Script 2 - has the actual task creation bit I think I need although this one is about setting task to remind user to do something in 2 weeks or something:
Sub AddOutlookTask()
Dim olApp As Object
Dim olItem As Object
Dim bStarted As Boolean
Dim fName As String
Dim flName As String
On Error Resume Next
If ActiveDocument.Saved = False Then
ActiveDocument.Save
If Err.Number = 4198 Then
MsgBox "Process ending - document not saved!"
GoTo UserCancelled:
End If
End If
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
'Outlook wasn't running, start it from code
Set olApp = CreateObject("Outlook.Application")
bStarted = True
End If
Set olItem = olApp.CreateItem(3) 'Task Item
fName = ActiveDocument.name
flName = ActiveDocument.FullName
olItem.Subject = "Follow up " & fName
olItem.Body = "If no reply to" & vbCr & _
flName & vbCr & "further action required"
olItem.StartDate = Date + 10 '10 days from today
olItem.DueDate = Date + 14 '14 days from today
olItem.Importance = 2 'High
olItem.Categories = InputBox("Category?", "Categories")
olItem.Save
UserCancelled:
If bStarted Then olApp.Quit
Set olApp = Nothing
Set olItem = Nothing
End Sub
How do I reference a particular table in MS-Word in code? I have bookmarked it so it has a "name" if that helps!
With Davids help (above) I have got the following solution to my problem. I post here for others if they come across a similar issue:
Sub CreateTasks()
'
' CreateTasks Macro
'
'
'
'Exports the contents of the ACtoins table to MS-Outlook Tasks
' Set Variables
Dim olApp As Object
Dim olItem As Object
Dim oTable As Table
Dim i As Long
Dim strSubject As Range
Dim strDueDate As Range
Dim strBody As Range
Dim strSummary As String
Dim bStarted As Boolean
'Dim strPupil As WdBookmark
Dim strPerson As Range
'Link to Outlook
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set olApp = CreateObject("Outlook.Application")
bStarted = True
End If
'Set table variable to the bookmarked table
Set oTable = ActiveDocument.Bookmarks("Actions").Range.Tables(1)
'Ignore the first (header) row of the table
For i = 3 To oTable.Rows.Count
Set strSubject = oTable.Cell(i, 3).Range
strSubject.End = strSubject.End - 1
Set strBody = oTable.Cell(i, 4).Range
strBody.End = strBody.End - 1
Set strDueDate = oTable.Cell(i, 5).Range
strDueDate.End = strDueDate.End - 1
'next line not working below
'Set strPupil = WdBookmark.Name
'Create the task
Set olItem = olApp.CreateItem(3) 'Task Item
strSummary = Left(strSubject, 30)
olItem.Subject = "CYPP Action for" & " " & strBody & "-" & strSummary & "..."
olItem.Body = strBody & vbNewLine & olItem.Body & vbNewLine & strSubject
olItem.DueDate = strDueDate & olItem.DueDate
olItem.Categories = "CYPP"
olItem.Save
Next i
If bStarted Then olApp.Quit
Set olApp = Nothing
Set olItem = Nothing
Set oTable = Nothing
End Sub
I will be adding to this to deal with empty rows but I am pleased with the functionality so far. The DateDue is not working yet but I think that is a formatting issue.
Thanks again David,
Richard.

Looping through every subfolder in inbox using vba

I have a problem looping through every sub-folder of an Outlook email using following code:
Sub HowManyEmails()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next
'Set objFolder = ActiveExplorer.CurrentFolder
Set objFolder = Session.GetFolderFromID (Application.ActiveExplorer.CurrentFolder.EntryID)
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
EmailCount = objFolder.Items.Count
' MsgBox "Number of emails in the folder: " & EmailCount, , "email count"
Dim dateStr As String
Dim myItems As Outlook.Items
Dim dict As Object
Dim msg As String
Dim oStartDate As String
Dim oEndDate As String
Set dict = CreateObject("Scripting.Dictionary")
oStartDate = InputBox("Type the start date (format MM/DD/YYYY)")
oEndDate = InputBox("Type the end date (format MM/DD/YYYY)")
Set myItems = objFolder.Items.Restrict("[Received] >= '" & oStartDate & "' And [Received] <= '" & oEndDate & "'")
myItems.SetColumns ("Categories")
' date for mssg:
For Each myItem In myItems
dateStr = myItem.Categories
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
' Output for days
msg = ""
For Each o In dict.Keys
msg = msg & o & ": " & dict(o) & vbCrLf
Next
MsgBox msg
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub
The code runs on the inbox itself, but it doesn't dig into sub-folders.
I have been trying to loop it correctly but I keep failing.
Thanks for help!
The code in ProcessFolder will call itself for each subfolder within the parent folder.
Option Explicit
Private MessageText As String
Public Sub ListAllFolders()
'Dim oOutlook As Object 'Outlook.Application
Dim nNameSpace As Object 'Outlook.Namespace
Dim mFolderSelected As Object 'Outlook.MAPIFolder
'''''''''''''''''''''''''''''''''''''''''
'No need to reference the Outlook application as the code
'is running from within the application itself.
''''''''''''''''''''''''''''''''''''''''
'Set oOutlook = GetObject(, "Outlook.Application")
'Set nNameSpace = oOutlook.GetNamespace("MAPI")
Set nNameSpace = GetNamespace("MAPI")
Set mFolderSelected = nNameSpace.PickFolder
ProcessFolder mFolderSelected
MsgBox MessageText
End Sub
Private Sub ProcessFolder(oParent As Object)
Dim oFolder As Object 'Outlook.MAPIFolder
Dim oMail As Object
Dim sName As String
'Get the folder name and count of items.
MessageText = MessageText & oParent.Name & ": " & oParent.Items.Count & vbCr
'If there are subfolders then process them as well.
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
ProcessFolder oFolder
Next oFolder
End If
End Sub
Edit:
This is the code I use to count the different categories of emails in the selected folder & subfolders.
It splits the count by date and category:
Public Sub CreateReport()
Dim oOutlook As Object 'Outlook.Application
Dim nNameSpace As Object 'Outlook.Namespace
Dim mFolderSelected As Object 'Outlook.MAPIFolder
Dim oItem As Object
Dim rLastCell As Range
Dim x As Long
Set oOutlook = GetObject(, "Outlook.Application")
Set nNameSpace = oOutlook.GetNamespace("MAPI")
Set mFolderSelected = nNameSpace.PickFolder
''''''''''''''''''''''''''''''''
'Clear Sheet of existing data. '
''''''''''''''''''''''''''''''''
shtAnalysis.Cells.Delete Shift:=xlUp
ProcessFolder mFolderSelected
''''''''''''''''''''''''''
'Tidy up and add totals. '
''''''''''''''''''''''''''
Set rLastCell = LastCell(shtAnalysis)
ThisWorkbook.Activate
MsgBox "Complete", vbOKOnly
End Sub
Private Sub ProcessFolder(oParent As Object)
Dim oFolder As Object 'Outlook.MAPIFolder
Dim oMail As Object
Dim sName As String
Dim PropertyAccessor As Object
Dim v As Variant
On Error Resume Next
For Each oMail In oParent.Items
PlaceDetails oMail
Next oMail
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
ProcessFolder oFolder
Next oFolder
End If
On Error GoTo 0
End Sub
Sub PlaceDetails(oMailItem As Object)
Dim rFoundCell As Range
Dim lColumn As Long
Dim lRow As Long
'''''''''''''''''''''''''''''''''''''''''''''
'Only process emails containing a category. '
'''''''''''''''''''''''''''''''''''''''''''''
If oMailItem.categories <> "" Then
With shtAnalysis
''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Does the category already exist on the spreadsheet? '
''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set rFoundCell = .Rows("1:1").Cells.Find(What:=oMailItem.categories, After:=.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not rFoundCell Is Nothing Then
lColumn = rFoundCell.Column
Else
lColumn = LastCell(shtAnalysis).Column + 1
End If
Set rFoundCell = Nothing
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Next find the row by looking for sent on date in column A. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set rFoundCell = .Columns("A:A").Cells.Find(What:=Int(oMailItem.senton), After:=.Cells(2, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not rFoundCell Is Nothing Then
lRow = rFoundCell.Row
Else
lRow = LastCell(shtAnalysis).Row + 1
End If
Set rFoundCell = Nothing
'''''''''''''''''''''''''''''''''''''''''''''''
'Place category, date and count on the sheet. '
'''''''''''''''''''''''''''''''''''''''''''''''
.Cells(lRow, 1).Value = Int(oMailItem.senton)
.Cells(1, lColumn).Value = oMailItem.categories
If .Cells(lRow, lColumn) = "" Then
.Cells(lRow, lColumn).NumberFormat = "General"
.Cells(lRow, lColumn) = 1
Else
.Cells(lRow, lColumn) = .Cells(lRow, lColumn) + 1
End If
End With
End If
End Sub
Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range
Dim lLastCol As Long, lLastRow As Long
On Error Resume Next
With wrkSht
If Col = 0 Then
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
Else
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
End If
If lLastCol = 0 Then lLastCol = 1
If lLastRow = 0 Then lLastRow = 1
Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
End With
On Error GoTo 0
End Function

Runtime error looping through Outlook items

I am using VBA in Outlook to extract mail information from items in the mainfolder and subfolder. The mainfolder failed to set(capture) the subfolder properties into it and it causes the runtime error.
The runtime error differs whenever I run. For example, sometime I received -970718969 (c6240107) and another time I received -2044460793 (86240107).
When I clicked debug, it points to this line of code:
For Each itm In subFld.Items
Here is the screenshot:
Here is the full code:
Public monthValue As Integer
Public yearValue As String
'Ensure Microsoft Excel 11.0 Object Library is ticked in tools.
Sub ExportToExcel1()
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim mainFld As Outlook.MAPIFolder
Dim subFld As Outlook.MAPIFolder
Dim itm As Object
Dim offsetRow As Long
Dim emailCount As Long
'Set the path of the excel file.
strSheet = "For fun.xlsx"
strPath = "C:\Users\xxxxxx\Desktop\xxxxx\"
strSheet = strPath & strSheet
Debug.Print strSheet
Set nms = Application.GetNamespace("MAPI")
Set mainFld = nms.PickFolder 'Open the box to select the file.
'Handle potential errors with Select Folder dialog box.
If mainFld Is Nothing Then
MsgBox "Thank you for using this service.", vbOKOnly, "Error"
Set nms = Nothing
Set mainFld = Nothing
Exit Sub
ElseIf mainFld.DefaultItemType <> olMailItem Then
MsgBox "Please select the correct folder.", vbOKOnly, "Error"
Set nms = Nothing
Set mainFld = Nothing
Exit Sub
ElseIf mainFld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Set nms = Nothing
Set mainFld = Nothing
Exit Sub
End If
mainForm.Show
'If user clicks cancel, it will exit sub.
If yearValue = "" Then
Set nms = Nothing
Set mainFld = Nothing
Exit Sub
End If
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True 'Show my workbook.
'Check if there are any subfolders.
If mainFld.Folders.Count = 0 Then '1
'No subfolder.
For Each itm In mainFld.Items
If itm.Class <> olMail Then '2
'do nothing
Else
Set msg = itm
'Validate the month and year for the email.
If Month(msg.ReceivedTime) = monthValue And Year(msg.ReceivedTime) = yearValue Then '3
With wks
offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
intRowCounter = 1 + offsetRow
Set rng = wks.Cells(intRowCounter, 1)
rng.Value = msg.ReceivedTime
Set rng = wks.Cells(intRowCounter, 2)
rng.Value = msg.SentOn
Set rng = wks.Cells(intRowCounter, 3)
rng.Value = msg.Subject
emailCount = 1 + emailCount 'Track the number of email.
Else
'Do nothing
End If '3
End If '2
Next itm
Else
'With subfolder
For Each itm In mainFld.Items
If itm.Class <> olMail Then '4
'do nothing
Else
Set msg = itm
If Month(msg.ReceivedTime) = monthValue And Year(msg.ReceivedTime) = yearValue Then '5
With wks
offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
intRowCounter = 1 + offsetRow
Set rng = wks.Cells(intRowCounter, 1)
rng.Value = msg.ReceivedTime
Set rng = wks.Cells(intRowCounter, 2)
rng.Value = msg.SentOn
Set rng = wks.Cells(intRowCounter, 3)
rng.Value = msg.Subject
emailCount = 1 + emailCount
Else
'Do nothing
End If '5
End If '4
Next itm
For Each subFld In mainFld.Folders
For Each itm In subFld.Items
If itm.Class <> olMail Then '6
'do nothing
Else
Set msg = itm
If Month(msg.ReceivedTime) = monthValue And Year(msg.ReceivedTime) = yearValue Then '7
With wks
offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
intRowCounter = 1 + offsetRow
Set rng = wks.Cells(intRowCounter, 1)
rng.Value = msg.ReceivedTime
Set rng = wks.Cells(intRowCounter, 2)
rng.Value = msg.SentOn
Set rng = wks.Cells(intRowCounter, 3)
rng.Value = msg.Subject
emailCount = 1 + emailCount
Else
'Do nothing
End If '7
End If '6
Next itm
Next subFld
End If '1
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set mainFld = Nothing
Set subFld = Nothing
Set itm = Nothing
'Inform the user that there are no email.
If emailCount = 0 Then
MsgBox "No emails associated with this date: " & MonthName(monthValue, True) & " " & yearValue, vbOKOnly, "No Emails"
End If
Exit Sub
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set mainFld = Nothing
Set subFld = Nothing
Set itm = Nothing
End Sub
Do you get that error immediately or only after processing a large number of items? Most likely you are opening too many items and run out of RPC channels. Is this a cached or an online Exchange profile?
Instead of looping through all items, use the Table object (MAPITable.GetTable) - if nothing else, it will be a lot faster.
EDIT: If you are using Exchange, every store object (message, folder, store) opens an RPC channel. Exchange Server limits the number of RPC channels to 255 per client (can be changed on the server). Do not use "for each" loop (it keeps all items referenced until the loop ends) and avoid multiple dot notation (because you will have implicit variables that you cannot explicitly dereference). You will also need to release all Outlook objects as soon as you are done with them.
set fldItems = mainFld.Items
For i = 1 to fldItems.Count do
set itm = fldItems.Item(i)
'do stuff
set itm = Nothing
next
As for the Table object (introduced in Outlook 2007), see http://msdn.microsoft.com/en-us/library/office/ff860769.aspx. If you need to use this in an earlier version of Outlook, you can use the MAPITable object in Redemption (I am its author); it also has a MAPITable.ExecSQL method that takes a standard SQL query and returns the ADODB.Recordset object.