Outlook VBA to report all incomplete tasks

I want to get Outlook Tasks/To Do data into an Excel report. However I am a noob when it comes to VBA in Outlook. I tried searching for existing code on the net but none of what I tried did what I want. The closest found created a report but it only reported a few of my tasks I had open (It used 'GetDefaultFolder(olFolderTasks)')

I am guessing that i need to loop through the MAPI? folders? in Outlook to pick up all of my tasks. Below is my attempt at mixing code from over the net to loop through my outlook folders and report any task that is incomplete. However I can't get the code to work. I run it on my Inbox folder and it doesn't detect any tasks. I probably have the looping code wrong but I can't work out where. Can anybody help?

'/ experiment with reporting on tasks in Outlook
'
'/ before starting:
'       copy/paste this code into Outlook (Alt + F11 to open Outlook VBA)
'       open folder location Environ("appdata")
'       in this location create an empty workbook named "ReportOpenTasks.xlsx"



Option Explicit
Option Private Module

Private xlWbk As Object 'Excel.Workbook
Private lngRow As Long

Public Sub ExportTasksAsReport()
    Dim mytoplvl As Variant
    Dim blnProcessed As Boolean
    Dim objExcel As Object
    Dim strMyName As String

    'reference existing workbook. set header for report
    Set objExcel = CreateObject("Excel.Application")
    Set xlWbk = objExcel.Workbooks.Open(Environ("appdata") & "\ReportOpenTasks.xlsx")
    xlWbk.Sheets("Sheet1").Cells(1, 1) = "Desc"
    xlWbk.Sheets("Sheet1").Cells(1, 2) = "Due"
    xlWbk.Sheets("Sheet1").Cells(1, 3) = "Status"
    lngRow = 2


    'loop through outlook folders
    Set mytoplvl = Outlook.GetNamespace("MAPI").PickFolder.Folders
    Do
        Call LoopFolders(mytoplvl, blnProcessed)
    Loop Until blnProcessed = False

     'autofit all column widths then save and close workbook
      With xlWbk.Sheets("Sheet1")
        .Columns("A").EntireColumn.AutoFit
        .Columns("B").EntireColumn.AutoFit
        .Columns("C").EntireColumn.AutoFit
    End With
    xlWbk.Save
    xlWbk.Close
    Set xlWbk = Nothing
End Sub

Private Sub LoopFolders(ByRef mytoplvl As Variant, ByRef blnProcessed As Boolean)
    Dim olFdr As Folder

    blnProcessed = False

    If mytoplvl.Count <> 0 Then

        For Each olFdr In mytoplvl

            If olFdr.Folders.Count > 1 Then
                'Folder contains sub folders
                LoopFolders olFdr.Folders, blnProcessed
            ElseIf olFdr.Items.Count < 1 Then
                'folder is empty
                blnProcessed = True
            Else
                Call CheckFolderForTasks(olFdr)
                blnProcessed = False
            End If
        Next olFdr
    Else
Debug.Assert False
    End If
End Sub

Private Sub CheckFolderForTasks(ByRef olFdr As Folder)
    Dim olItems As Outlook.Items
    Dim olTsk As Outlook.TaskItem
    Dim i As Long

    Set olItems = olFdr.Items

    For i = 1 To olItems.Count

        If olItems(i).Class = olTask Then

            Set olTsk = olItems.Item(i)

             If Not olTsk.Complete Then
                xlWbk.Sheets("Sheet1").Cells(lngRow, 1) = olTsk.Subject
                xlWbk.Sheets("Sheet1").Cells(lngRow, 2) = olTsk.DueDate
                xlWbk.Sheets("Sheet1").Cells(lngRow, 3) = olTsk.Status
                lngRow = lngRow + 1
             End If
         End If
    Next i


    Set olTsk = Nothing
    Set olItems = Nothing
End Sub

Here's an example how to export Outlook Task Item to Excel by running the macro in Outlook. Make sure you have the MS Excel Library reference checked. If you only want to export task item with specific criteria, then, add your IF condition accordingly.

Here's the MS Documentation of all the task item property
'https://msdn.microsoft.com/en-us/library/office/dn352390.aspx

Sub Export_TaskItems()
Dim NS As NameSpace
Dim TaskFolder As folder
Dim item As Object
Dim TaskItem As TaskItem

Dim xlApp As Excel.Application
Dim xlwb As Excel.Workbook
Dim xlws As Excel.Worksheet
Dim iRow As Long

Set xlApp = CreateObject("Excel.Application")
Set xlwb = xlApp.Workbooks.Add
Set xlws = xlwb.Worksheets(1)
xlws.Range("A1").Resize(1, 4).Value = Array("Status", "Due Date", "Owner Name", "Priority")
iRow = 2


Set NS = Session

Set TaskFolder = NS.GetDefaultFolder(olFolderTasks)

For Each item In TaskFolder.Items
    If item.Class = olTask Then
        
        Set TaskItem = item
        
        '0 Not started; 1 In Progress; 2 Complete; 3 Waiting; 4 Deferred
        xlws.Cells(iRow, 1).Value = TaskItem.Status
        xlws.Cells(iRow, 2).Value = TaskItem.DueDate
        xlws.Cells(iRow, 3).Value = TaskItem.Owner
        xlws.Cells(iRow, 4).Value = TaskItem.Importance

        iRow = iRow + 1
    End If
Next item

xlApp.Visible = True
Set xlApp = Nothing

End Sub

Thanks JieJenn - this is very similar to the nearest match I have found so far (as mentioned in the OP) The code doesn't pick up all my incomplete tasks as it uses GetDefaultFolder instead of looping through all folders to pick up tasks outside the standard Tasks folder.

When you say incomplete task, do you mean Status is not equals to "Completed"?

Originally Posted by JieJenn

When you say incomplete task, do you mean Status is not equals to "Completed"?

Correct. But that is not the problem, as per code in my OP, I can easily deal with those using

If Not olTsk.Complete Then

While your code works, it only lists tasks in the default Tasks folder and my tasks are across multiple folders. So I need code which will recursive search all outlook folders & subfolders. I tried writing this myself (see code in post 1) but it doesn't appear to be working.

Your code only processes the folders within the folder you selected, not that folder itself.

Originally Posted by rorya

Your code only processes the folders within the folder you selected, not that folder itself.

Yes, I know I have problems with the folder looping. I discovered another error, I am skipping subfolders where their parent folder doesn't contain items!

I am stepping through the folder loop function to see if I can solve it.

However I think I may also have problems with reading the tasks themselves (The subprocedure 'CheckFolderForTasks') UPDATE: For one thing, I have just discovered I need to edit the code to pick up mail items flagged as tasks.

I made several changes to the code and it looks as if it is starting to work. However there are several problems:

1. Speed. Looping through the folders is extremely slow. It would be quicker to read the 'To Do' 'view' in Outlook - if that is even possible. But how?
2. I'm not certain that the looping code is working 100% I would appreciate anyone pointing out if they can see any logic flaw in this code
3. Not a bug/just haven't coded - If it is not possible to read the To Do view then I need to also pick up the tasks in the Task folder and merge with the mail item tasks.

'/ experiment with reporting on tasks in Outlook
'
'/ before starting:
'       copy/paste this code into Outlook (Alt + F11 to open Outlook VBA)
'       open folder location Environ("appdata")
'       in this location create an empty workbook named "ReportOpenTasks.xlsx"

'/ TO DO
'   is the folder looping working correctly now?
'   This picks up email messages flagged as tasks, I need to amalgate this code with the tasks in the Tasks folder
'   SPEED! This is slow. Ideally should grab data from Outlooks To Do view instead of looping through every subfolder. But is that even possible to grab the data from this view? If it is, how do I find out?


Option Explicit
Option Private Module

Private mxlWbk As Object 'Excel.Workbook
Private mlngRow As Long
Private mavar As Variant

Public Sub ExportTasksAsReport()
    Dim mytoplvl As Variant
    Dim blnProcessed As Boolean
    Dim avar2 As Variant

    mlngRow = 2
    ReDim mavar(1 To 3, 1 To mlngRow)
    mavar(1, 1) = "Desc"
    mavar(2, 1) = "Due"
    mavar(3, 1) = "Status"
    mlngRow = 1

    'loop through outlook folders
    Set mytoplvl = Outlook.GetNamespace("MAPI").PickFolder.Folders
    Do
        pLoopFolders mytoplvl, blnProcessed
    Loop Until blnProcessed = False

    'outlook doesnt have a transpose function?
    ReDim avar2(1 To UBound(mavar, 2), 1 To 3)
    For mlngRow = LBound(mavar, 2) To UBound(mavar, 2)
        avar2(mlngRow, 1) = mavar(1, mlngRow)
        avar2(mlngRow, 2) = mavar(2, mlngRow)
        avar2(mlngRow, 3) = mavar(3, mlngRow)
    Next mlngRow

    Call pWriteArrToExistingExcelFile(avar2)
End Sub

Private Sub pWriteArrToExistingExcelFile(ByRef avar2 As Variant)
    Dim objExcel As Object

    ' reference existing workbook. set header for report
    Set objExcel = CreateObject("Excel.Application")
    Set mxlWbk = objExcel.Workbooks.Open(Environ("appdata") & "\ReportOpenTasks.xlsx")
'    With mxlWbk.Sheets("Sheet1")
'        .Cells(1, 1) = "Desc"
'        .Cells(1, 2) = "Due"
'        .Cells(1, 3) = "Status"
'    End With

    'autofit all column widths then save and close workbook
    With mxlWbk.Sheets("Sheet1")
        .Cells(1, 1).Resize(UBound(avar2), 3) = avar2
        .Columns("A").EntireColumn.AutoFit
        .Columns("B").EntireColumn.AutoFit
        .Columns("C").EntireColumn.AutoFit
    End With
    mxlWbk.Save
    DoEvents
    mxlWbk.Close

    Set mxlWbk = Nothing
End Sub

Private Sub pLoopFolders(ByRef mytoplvl As Variant, ByRef blnProcessed As Boolean)
    Dim olFdr As Folder

    blnProcessed = False

    If mytoplvl.Count <> 0 Then

        For Each olFdr In mytoplvl

'Debug.Print Format(Now(), "hhmmss") & " GET " & olFdr.Name

            If olFdr.Items.Count > 0 Then
                pCheckFolderForTasks olFdr
            Else
                'folder contains no items
                blnProcessed = True
            End If

            If olFdr.Folders.Count > 1 Then
                'folder contains sub folders
                pLoopFolders olFdr.Folders, blnProcessed
            Else
                blnProcessed = False
            End If
        Next olFdr
    Else
Debug.Assert False
    End If
End Sub

Private Sub pCheckFolderForTasks(ByRef olFdr As Folder)
    Dim olItems As Outlook.Items
    Dim i As Long

    DoEvents 'uncertain

    Set olItems = olFdr.Items

    For i = 1 To olItems.Count

        With olItems(i)
            Select Case .Class
            Case olMail
                If .IsMarkedAsTask Then
'                    mxlWbk.Sheets("Sheet1").Cells(mlngRow, 1) = .Subject
'                    mxlWbk.Sheets("Sheet1").Cells(mlngRow, 2) = .TaskDueDate
'                    mxlWbk.Sheets("Sheet1").Cells(mlngRow, 3) = .FlagStatus 'is this the appropriate equivalent to Task Status?
                    mlngRow = mlngRow + 1

                    ReDim Preserve mavar(1 To 3, 1 To mlngRow)
                    mavar(1, mlngRow) = .Subject
                    mavar(2, mlngRow) = .TaskDueDate
                    mavar(3, mlngRow) = .FlagStatus 'is this the appropriate equivalent to Task Status?
                End If
            Case olTask
'not sure if even possible to have a Task item outside the Task folder? (I am a noob at Outlook VBA)

                If Not .Complete Then
'                    mxlWbk.Sheets("Sheet1").Cells(mlngRow, 1) = .Subject
'                    mxlWbk.Sheets("Sheet1").Cells(mlngRow, 2) = .DueDate
'                    mxlWbk.Sheets("Sheet1").Cells(mlngRow, 3) = .Status
                    mlngRow = mlngRow + 1

                    ReDim Preserve mavar(1 To 3, 1 To mlngRow)
                    mavar(1, mlngRow) = .Subject
                    mavar(2, mlngRow) = .DueDate
                    mavar(3, mlngRow) = .Status
                End If
            End Select
        End With
    Next i

    Set olItems = Nothing
End Sub

Persistence occasionally pays off. Below is quick and dirty code which solves this thread.

'/ Export Outlooks ToDo to Excel workbook
'
'/ before starting:
'       copy/paste this code into Outlook (Alt + F11 to open Outlook VBA)
'       open folder location Environ("appdata")
'       in this location create an empty workbook named "ReportOpenTasks.xlsx"

Option Explicit
Option Private Module

Private mlngRow As Long
Private mavar As Variant

Public Sub ExportToDoListAsReport()
    Dim fdrToDo As Folder
    Dim avar2 As Variant

    mlngRow = 2
    ReDim mavar(1 To 3, 1 To mlngRow)
    mavar(1, 1) = "Desc"
    mavar(2, 1) = "Due"
    mavar(3, 1) = "Status"
    mlngRow = 1

    Set fdrToDo = Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderToDo)

    Call pCheckFolderForTasks(fdrToDo)

    'outlook doesnt have a transpose function?
    ReDim avar2(1 To UBound(mavar, 2), 1 To 3)
    For mlngRow = LBound(mavar, 2) To UBound(mavar, 2)
        avar2(mlngRow, 1) = mavar(1, mlngRow)
        avar2(mlngRow, 2) = mavar(2, mlngRow)
        avar2(mlngRow, 3) = mavar(3, mlngRow)
    Next mlngRow

    Call pWriteArrToExistingExcelFile(avar2)

    Debug.Print "Check Excel workbook now"
End Sub

Private Sub pCheckFolderForTasks(ByRef olFdr As Folder)
    Dim olItems As Outlook.Items
    Dim i As Long

    Set olItems = olFdr.Items

    For i = 1 To olItems.Count

        With olItems(i)
            Select Case .Class
            Case olMail
                If .IsMarkedAsTask Then
                    mlngRow = mlngRow + 1

                    ReDim Preserve mavar(1 To 3, 1 To mlngRow)
                    mavar(1, mlngRow) = .Subject
                    mavar(2, mlngRow) = .TaskDueDate
                    mavar(3, mlngRow) = .FlagStatus 'is this the appropriate equivalent to Task Status?
                End If
            Case olTask
                If Not .Complete Then
                    mlngRow = mlngRow + 1

                    ReDim Preserve mavar(1 To 3, 1 To mlngRow)
                    mavar(1, mlngRow) = .Subject
                    mavar(2, mlngRow) = .DueDate
                    mavar(3, mlngRow) = .Status
                End If
            End Select
        End With
    Next i

    Set olItems = Nothing
End Sub

Private Sub pWriteArrToExistingExcelFile(ByRef avar2 As Variant)
    Dim objExcel As Object
    Dim xlWbk As Object 'Excel.Workbook

    ' reference existing workbook. set header for report
    Set objExcel = CreateObject("Excel.Application")
    Set xlWbk = objExcel.Workbooks.Open(Environ("appdata") & "\ReportOpenTasks.xlsx")

    'paste data, autofit all column widths then save and close workbook
    With xlWbk.Sheets("Sheet1")
        .Cells(1, 1).Resize(UBound(avar2), 3) = avar2
        .Columns("A").EntireColumn.AutoFit
        .Columns("B").EntireColumn.AutoFit
        .Columns("C").EntireColumn.AutoFit
    End With
    xlWbk.Save
    DoEvents
    xlWbk.Close
    Set xlWbk = Nothing
End Sub