Consulting

Results 1 to 13 of 13

Thread: Import Outlook-Taks in an Excel-Sheet

  1. #1
    VBAX Newbie
    Joined
    Nov 2017
    Posts
    3
    Location

    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
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,633
    Location
    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.

  3. #3
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,633
    Location
    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

  4. #4
    VBAX Newbie
    Joined
    Nov 2017
    Posts
    3
    Location
    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
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,633
    Location
    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
    VBAX Newbie
    Joined
    Nov 2017
    Posts
    3
    Location
    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
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,633
    Location
    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

  8. #8
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,633
    Location
    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

  9. #9
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,416
    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

  10. #10
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,633
    Location
    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
    Last edited by Kenneth Hobs; 11-15-2017 at 10:05 AM.

  11. #11
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,416
    @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

  12. #12
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,633
    Location
    Even better but j+0 should be j+1...
    Last edited by Kenneth Hobs; 11-15-2017 at 01:22 PM.

  13. #13
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,416
    @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
  •