Import Outlook-Taks in an Excel-Sheet

Hey guys,

I would like to import Information of Outlook-Tasks in an Excel-Sheet.
Therefor the Marco should do the following things:
1. Open a Listbox, which shows alle TaskFolders of Outlook as a List.
2. The User marks the List he wants and presses "OK"
3. Following Information of all the tasks in the selected List will be importet in the Excel-Sheet in, for every task in a new Row : Subject, CreationTime, DueDate, Body and Complete.

Would be great, if someone can help me. I'm quite new in VBA.
The only thing I have so far is th code below.
My biggest problem is showing the box with all the Task-Lists and selecting one of them.

Thank you so much.

Cheers,
Pascal

Sub GetOLTasks()
Dim OL As Outlook.Application, objFolder As Outlook.MAPIFolder
Dim objTask As Outlook.TaskItem, objRecipient As Outlook.Recipient, objAction As Outlook.Action
Dim objSheet As Excel.Worksheet
Dim i As Long, S As String

On Error GoTo Fehler

Set OL = CreateObject("Outlook.Application")
Set objFolder = OL.GetNamespace("MAPI").GetDefaultFolder(olFolderTasks)
'Missing part for opening a ListBox with all the TaskFolders as content to select

Set objSheet = Application.Worksheets(3)

With objSheet
.Cells.Clear
.Cells(1, 1) = "Subject"
.Cells(1, 2) = "CreationTime"
.Cells(1, 3) = "DueDate"
.Cells(1, 4) = "Body"
.Cells(1, 5) = "Complete"
End With
i = 2
For Each objTask In objFolder.Items
With objSheet
.Cells(i, 1) = objTask.Subject
.Cells(i, 2) = objTask.CreationTime
.Cells(i, 3) = objTask.DueDate
.Cells(i, 4) = objTask.Body
.Cells(i, 5) = objTask.Complete
End With
i = i + 1
Next objTask

Ende:
Set objFolder = Nothing
Set objTask = Nothing
Set objSheet = Nothing
Set OL = Nothing
Exit Sub

Fehler:
MsgBox Err.Description
Resume Ende
End Sub

Welcome to the forum!

If that works for you, then the UsedRange can be used to fill the List. e.g.

Code:

---

Private Sub UserForm_Initialize() 
  Dim r As Range

  GetOLTasks
  Set r = Sheet3.UsedRange
  ListBox1.ColumnCount = r.Columns.Count
  ListBox1.List = r.Value
End Sub

---

Tip: Paste code between code tags to keep structure. Click the # icon on reply toolbar to insert code tags.

Since I use Gmail, my task folder is in another location. Even so, you should be able to adapt this if you like the concept of writing all tasks to the sheet in one step.

Code:

---

'gmail GetOLTasks
Sub gGetOLTasks()
  'Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
  Dim OL As Outlook.Application, ot As Outlook.TaskItem
  Dim objRecipient As Outlook.Recipient, objAction As Outlook.Action
  'Dim objFolder As Outlook.MAPIFolder
  Dim objFolder As Outlook.Folder 'For Gmail Task's folder
  Dim objSheet As Worksheet
  Dim i As Long, S As String, ws As Worksheet, a
 
  On Error GoTo ErrorEnd
'******************* INPUT ******************************************************************
  Set ws = Sheet3
'******************* END INPUT **************************************************************
 
  Set OL = CreateObject("Outlook.Application")
  'Set objFolder = OL.GetNamespace("MAPI").GetDefaultFolder(olFolderTasks) 'olFolderTasks=13
  Set objFolder = GetFolderPath("\\ken@gmail.com\Tasks (This computer only)", OL)
  If objFolder.Items.Count = 0 Then GoTo FinalEnd
 
  'Add and fill column header row.
  a = Split("Subject,CreationTime,DueDate,Body,Complete", ",")
  ws.Cells.ClearContents
  ws.[A1].Resize(, UBound(a) + 1).Value = a


  ReDim a(1 To objFolder.Items.Count, 1 To 5)
  For i = 1 To objFolder.Items.Count
    Set ot = objFolder.Items(i)
    With ot
      a(i, 1) = .Subject
      a(i, 2) = .CreationTime
      a(i, 3) = .DueDate
      a(i, 4) = .Body
      a(i, 5) = .Complete
    End With
  Next i
 
  'Add Task Items to ws.
  ws.[A2].Resize(i, 5).Value = a
  ws.UsedRange.EntireColumn.AutoFit
 
FinalEnd:
  Set objFolder = Nothing
  Set ot = Nothing
  Set ws = Nothing
  Set OL = Nothing
  Exit Sub
 
ErrorEnd:
  MsgBox Err.Description
  Resume FinalEnd
End Sub

---

Thanks a lot Kenneth for your quick response.
Unfortunately it's not the thing I was looking for (I guess so :D).
The listbox should open, so that the user can choose which Task-List he wants to import the tasks from.
After choosing the list, the macro imports the requiered information of alle tasks that are in this chosen list.
Do you know how I could implement this?
Thanks a lot in advance :-)

That is easily done. One just sets the List property to a. Next, we add code to allow MultiSelect and then paste that list converted to an array instead.

Is the Listbox, on the sheet and if so, is it ActiveX or a Form control or is it a Userform Listbox?

Howsoever, make sure that the code that I posted "works" for you first. I can adjust it if you are not using Gmail. It doesn't take much effort but I can do it for you if needed. That is Step 1...

Hey Kennth,

the Listbox shall pop up once I open the Marco. I would use a Userform-Listbox.

The code you sent we is great. I would have to adjust it to an Exchange account, since I'm not using gmail.

See if this does get the tasks. IF not, I can show you how to get the Tasks folder name in an Outlook macro.

This is easily made into a function to return a, the array of task data. Depending on what you want, it might be better to import all and then filter as needed. Of course some things could be filtered in the array depending on what you want. e.g. tasks completed = True.

Code:

---

Sub GetOLTasks()  'Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
  Dim OL As Outlook.Application, ot As Outlook.TaskItem
  Dim objRecipient As Outlook.Recipient, objAction As Outlook.Action
  Dim objFolder As Outlook.MAPIFolder
  'Dim objFolder As Outlook.Folder 'For Gmail Task's folder
  Dim objSheet As Worksheet
  Dim i As Long, S As String, ws As Worksheet, a
 
  On Error GoTo ErrorEnd
'******************* INPUT ******************************************************************
  Set ws = Sheet4
'******************* END INPUT **************************************************************
 
  Set OL = CreateObject("Outlook.Application")
  Set objFolder = OL.GetNamespace("MAPI").GetDefaultFolder(olFolderTasks) 'olFolderTasks=13
  'Set objFolder = GetFolderPath("\\kenneth.ray.hobson@gmail.com\Tasks (This computer only)", OL)
  If objFolder.Items.Count = 0 Then GoTo FinalEnd
 
  'Add and fill column header row.
  a = Split("Subject,CreationTime,DueDate,Body,Complete", ",")
  ws.Cells.ClearContents
  ws.[A1].Resize(, UBound(a) + 1).Value = a


  ReDim a(1 To objFolder.Items.Count, 1 To 5)
  For i = 1 To objFolder.Items.Count
    Set ot = objFolder.Items(i)
    With ot
      a(i, 1) = .Subject
      a(i, 2) = .CreationTime
      a(i, 3) = .DueDate
      a(i, 4) = .Body
      a(i, 5) = .Complete
    End With
  Next i
 
  'Add Task Items to ws.
  ws.[A2].Resize(i, 5).Value = a
  ws.UsedRange.EntireColumn.AutoFit
 
FinalEnd:
  Set objFolder = Nothing
  Set ot = Nothing
  Set ws = Nothing
  Set OL = Nothing
  Exit Sub
 
ErrorEnd:
  MsgBox Err.Description
  Resume FinalEnd
End Sub

---

The function would go into a Module:

Code:

---

Function fGetOLTasks() 
  'Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
  Dim OL As Outlook.Application, ot As Outlook.TaskItem
  Dim objRecipient As Outlook.Recipient, objAction As Outlook.Action
  Dim objFolder As Outlook.MAPIFolder
  'Dim objFolder As Outlook.Folder 'For Gmail Task's folder
  Dim objSheet As Worksheet
  Dim i As Long, S As String, ws As Worksheet, a
 
  On Error GoTo ErrorEnd
'******************* INPUT ******************************************************************
  Set ws = Sheet4
'******************* END INPUT **************************************************************
 
  Set OL = CreateObject("Outlook.Application")
  Set objFolder = OL.GetNamespace("MAPI").GetDefaultFolder(olFolderTasks) 'olFolderTasks=13
  'Set objFolder = GetFolderPath("\\kenneth.ray.hobson@gmail.com\Tasks (This computer only)", OL)
  If objFolder.Items.Count = 0 Then GoTo FinalEnd
 
  'Add and fill column header row.
  'a = Split("Subject,CreationTime,DueDate,Body,Complete", ",")
  'ws.Cells.ClearContents
  'ws.[A1].Resize(, UBound(a) + 1).Value = a


  ReDim a(1 To objFolder.Items.Count, 1 To 5)
  For i = 1 To objFolder.Items.Count
    Set ot = objFolder.Items(i)
    With ot
      a(i, 1) = .Subject
      a(i, 2) = .CreationTime
      a(i, 3) = .DueDate
      a(i, 4) = .Body
      a(i, 5) = .Complete
    End With
  Next i
 
  'Add Task Items to ws.
  'ws.[A2].Resize(i, 5).Value = a
  'ws.UsedRange.EntireColumn.AutoFit
 
FinalEnd:
  Set objFolder = Nothing
  Set ot = Nothing
  Set ws = Nothing
  Set OL = Nothing
  fGetOLTasks = a
  Exit Function
 
ErrorEnd:
  MsgBox Err.Description
  Resume FinalEnd
End Function

---

Userform code with Listbox and two CommandButton controls:

Code:

---

Private Sub UserForm_Initialize() 
  Dim a 'Only needed if dynamic columncount needs set.
  a = fGetOLTasks
  'ListBox1.ListStyle = fmListStyleOption
  'ListBox1.MultiSelect = fmMultiSelectExtended
  'ListBox1.ColumnCount = UBound(a, 2)
  ListBox1.List = a
End Sub


'Put selected items on sheet.
Private Sub CommandButton1_Click()
  Dim a
  'a = ListBox1.List  'All List items
  a = SelectedItemsToArray(ListBox1)  'Selected items
  If IsArray(a) Then _
    Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(a), UBound(a, 2)) = a
  ActiveSheet.UsedRange.EntireColumn.AutoFit
End Sub


Private Sub CommandButton2_Click()
  Unload Me
End Sub


'ctrl=Listbox or ComboBox Control
Function SelectedItemsToArray(ctrl As Control)
  Dim a, b, r As Long, c As Integer, i As Long
  a = ctrl.List 'Overfile array.
  ReDim b(1 To UBound(a) + 1, 1 To UBound(a, 2) + 1)
  'Fill array with just Selected Item data.
  For r = 1 To UBound(a) + 1
    If ctrl.Selected(r - 1) <> True Then GoTo NextR
    i = i + 1
    For c = 1 To UBound(a, 2) + 1
      b(i, c) = a(r - 1, c - 1)
    Next c
NextR:
  Next r
  'Resize to selected index row count, i.
  a = Application.Index(b, Application.Evaluate("row(1:" & i & ")"), _
    Application.Transpose([row(1:5)]))
  If i = 1 Then
    ReDim b(1 To 1, 1 To 5)
    For i = 1 To 5
      b(1, i) = a(i)
    Next i
    SelectedItemsToArray = b
    Else: SelectedItemsToArray = a
  End If
End Function

---

This might be sufficient to fill the listbox in the userform:

Code:

---

Private Sub Userform_initialize()
  Listbox1.List = F_snb
End Sub


Function F_snb()
    ReDim sn(2000, 4)
   
    For Each it In CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(13).items
      For jj = 0 To 4
        sn(j, jj) = Choose(jj + 1, it.Subject, it.CreationTime, it.DueDate, it.Body, it.Complete)
      Next
      j = j + 0
    Next
   
    F_snb = sn
End Function

---

For post #9, j+0 should be j+1. If you use snb's method, be sure to comment out or delete Option Explicit if you use it like I do.

If I used snb's method, I would trim the array so that no blank item rows were added. The easier way would be to get the total item count first.

Here is a trim method for post #9:

Code:

---

Function F_snb()   
    ReDim sn(1 To 65536, 1 To 5)
   
    For Each it In CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(13).items
        j = j + 1
        For jj = 1 To 5
            sn(j, jj) = Choose(jj, it.Subject, it.CreationTime, it.DueDate, it.Body, it.Complete)
        Next
    Next
   
    sn = Application.Index(sn, Application.Evaluate("row(1:" & j & ")"), _
        [column(1:5)])
    If j = 1 Then
        ReDim b(1 To 1, 1 To 5)
        For j = 1 To 5
          b(1, j) = sn(j)
        Next j
        F_snb = b
        Else: F_snb = sn
    End If
End Function

---

Here is the more simple version.

Code:

---

Function F_snb2()   
    Set ot = CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(13).items
    c = ot.Count
    If c = 0 Then Exit Function
   
    ReDim sn(1 To c, 1 To 5)
   
    For Each it In ot
        j = j + 1
        For jj = 1 To 5
            sn(j, jj) = Choose(jj, it.Subject, it.CreationTime, it.DueDate, it.Body, it.Complete)
        Next
    Next
   
    Set ot = Nothing
    F_snb2 = sn
End Function

---

@KH
Maybe simpler: :content:

Code:

---

Private Sub Userform_initialize()
  Listbox1.List = F_snb
  if ubound(Listbox1.column)=0 then Listbox1.column=Listbox1.List
End Sub
 
 
Function F_snb()
  with CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(13)
    redim sn(.items.count-1,4)

    For Each it In .items
        For jj = 0 To 4
            sn(j, jj) = Choose(jj + 1, it.Subject, it.CreationTime, it.DueDate, it.Body, it.Complete)
        Next
        j = j + 0
    Next
  end with
   
    F_snb = sn
End Function

---

Even better but j+0 should be j+1...

@KH

That's an essential improvement :yes