Consulting

Results 1 to 13 of 13

Thread: Import Outlook-Taks in an Excel-Sheet

  1. #1

    Question 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

  2. #2
    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 
    
    
    Formatting tags added by mark007
    Tip: Paste code between code tags to keep structure. Click the # icon on reply toolbar to insert code tags.

  3. #3
    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 
    
    
    Formatting tags added by mark007

  4. #4
    Thanks a lot Kenneth for your quick response.
    Unfortunately it's not the thing I was looking for (I guess so ).
    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 :-)

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

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

  7. #7
    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 
    
    
    Formatting tags added by mark007

  8. #8
    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 
    
    
    Formatting tags added by mark007
    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 
    
    
    Formatting tags added by mark007

  9. #9
    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 
    
    
    Formatting tags added by mark007

  10. #10
    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 
    
    
    Formatting tags added by mark007
    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 
    
    
    Formatting tags added by mark007
    Last edited by Kenneth Hobs; 11-15-2017 at 10:05 AM.

  11. #11
    @KH
    Maybe simpler:
    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 
    
    
    Formatting tags added by mark007

  12. #12
    Even better but j+0 should be j+1...
    Last edited by Kenneth Hobs; 11-15-2017 at 01:22 PM.

  13. #13
    @KH

    That's an essential improvement

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •