Import Outlook-Taks in an Excel-Sheet

[Pascal90]

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

[Kenneth Hobs]

Welcome to the forum!

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

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.

[Kenneth Hobs]

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.


'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

[Pascal90]

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 :-)

[Kenneth Hobs]

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...

[Pascal90]

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.

[Kenneth Hobs]

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.


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

[Kenneth Hobs]

The function would go into a Module:

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:

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

[snb]

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


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

[Kenneth Hobs]

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:

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.

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

[snb]

@KH
Maybe simpler: :content:

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

[Kenneth Hobs]

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

[snb]

@KH

That's an essential improvement :yes