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