none
Export Outlook emails to Excel RRS feed

  • Question

  • Hi,

    How can I export emails from a shared mailbox to excel and include all the subfolders as part of this export? I tried export function in Outlook but it doesn't allow me to export from the shared mailbox, only my own mailbox. I've googled a lot of other options but they don't include the subfolders as part of the export. I also tried exporting a PST file to Excel and that didn't work either.

    Appreciate your help.

    Thanks

    Ed

    Thursday, July 21, 2016 10:18 AM

Answers

  • Hmmm. If you replace

    Else
       Exit For

    with

    ElseIf Format(olItem.ReceivedTime, "yyyymmdd") <= _
                           Format(CDate(strEndDate), "yyyymmdd") Then
          Exit For

    The premature ending shoud be corrected.

    I noticed a typo in the code.

    xlSheet.Range("K" & rCount) = olFolder.FolderPath

    should be

    xlSheet.Range("L" & rCount) = olFolder.FolderPath
    The macro should process the selected folder and all its sub folders. It should not wander off to other parent folders.



    Graham Mayor - Word MVP
    www.gmayor.com


    Wednesday, August 3, 2016 5:46 AM
  • A Happy New Year to you also.

    There are some issues with your code. The most immediately obvious being that

    Environ("USERPROFILE") & "R:\FACSAPPS\FA\CUS\CRPACT\ED test.xlsx" is not a valid path. On the face of it, it should be

     "R:\FACSAPPS\FA\CUS\CRPACT\ED test.xlsx"

    The path "R:\FACSAPPS\FA\CUS\CRPACT\" should exist. If it doesn't it needs to be created, so in the same module add the following function and call it from a new line in the main code before the workbook is saved. i.e. Change

    strPath = Environ("USERPROFILE") & "R:\FACSAPPS\FA\CUS\CRPACT\ED test.xlsx"

    to

    strPath = "R:\FACSAPPS\FA\CUS\CRPACT\"
    CreateFolders strPath
    strPath = strPath &
    "ED test.xlsx"

    If the folder already exists the function doesn't do anything. However if the R drive is not available, this will also crash the system. I suspect that your crashes are related to the invalid path. If there is a possibility that R, which I assume is a mapped network drive, is not going to be available, you will have to trap that also, or work with a local path instead.

    Private Function CreateFolders(strPath As String)
    'An Office macro by Graham Mayor - www.gmayor.com
    Dim strTempPath As String
    Dim lngPath As Long
    Dim vPath As Variant
    Dim oFSO As Object
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        vPath = Split(strPath, "\")
        strPath = vPath(0) & "\"
        For lngPath = 1 To UBound(vPath)
            strPath = strPath & vPath(lngPath) & "\"
            If Not oFSO.FolderExists(strPath) Then MkDir strPath
        Next lngPath
    lbl_Exit:
        Set oFSO = Nothing
        Exit Function
    End Function


    Add

    Dim olRootFolder As Outlook.Folder

    to the variable declarations

    then add to or change the following section where indicated

        Set xlWb = xlApp.Workbooks.Add
        xlApp.Visible = True
        Set xlSheet = xlWb.Sheets("Sheet1")
        xlSheet.Name = "Raw Data"

        xlSheet.Range("A" & 1) = "Sender Name"
        xlSheet.Range("B" & 1) = "Sent To"
        xlSheet.Range("C" & 1) = "Sent On"
        xlSheet.Range("D" & 1) = "subject"
        xlSheet.Range("E" & 1) = "Conversation"
        xlSheet.Range("F" & 1) = "Categories"
        xlSheet.Range("G" & 1) = "Folder"
        xlSheet.Range("H" & 1) = "Job Title"
        xlSheet.Range("I" & 1) = "Department"
        On Error Resume Next
        rCount = 2

        Set cFolders = New Collection
        Set olRootFolder = Session.PickFolder
        If olRootFolder = "" Then
             MsgBox "User cancelled"
            xlWb.Close 0
            If bXStarted Then
                xlApp.Quit
            End If
            GoTo lbl_Exit
        End If
        cFolders.Add olRootFolder
        Do While cFolders.Count > 0



    Graham Mayor - Word MVP
    www.gmayor.com


    • Edited by Graham MayorMVP Sunday, January 1, 2017 5:30 AM
    • Marked as answer by Ed McArdle Wednesday, January 4, 2017 8:39 AM
    Sunday, January 1, 2017 5:19 AM

All replies

  • It is fairly straightforward to process a given folder and its sub folders in Outlook. All you need to do is locate the parent folder and add it and its sub folders to a collection e.g.

    Dim cFolders As Collection
    Dim olFolder As Outlook.Folder
    Dim subFolder As Folder
    
        Set cFolders = New Collection
        cFolders.Add Session.PickFolder
        Do While cFolders.Count > 0
            Set olFolder = cFolders(1)
            cFolders.Remove 1
            'Do something with the folder'
            For Each subFolder In olFolder.folders
                cFolders.Add subFolder
            Next subFolder
        Loop


    Graham Mayor - Word MVP
    www.gmayor.com

    Thursday, July 21, 2016 12:01 PM
  • Thank You.

    I can't get it to write the output to excel. Can you tell me what is wrong with the below code?

    Option Explicit
     Sub CopyToExcel()
     Dim xlApp As Object
     Dim xlWb As Object
     Dim xlSheet As Object
     Dim rCount As Long
     Dim bXStarted As Boolean
     Dim enviro As String
     Dim strPath As String
     Dim olApp As Outlook.Application
     Dim olSession As Outlook.NameSpace
     Dim olStartFolder As Outlook.MAPIFolder
     Dim mailitems As Outlook.Items
     Dim currentExplorer As Explorer
     Dim Selection As Selection
     Dim olItem As Outlook.MailItem
     Dim obj As Object
     Dim strColA, strColB, strColC, strColD, strColE, strColF, strColG, strColH, strColI, StrColJ, StrColK, StrColL, StrColM As String
     Dim LDate As Date
     Dim propertyAccessor As Outlook.propertyAccessor
     Dim PropName As String
     Dim LVE As String
     Dim LVET As String 'Date
     Dim dtUTC As Date
     Dim dtLocal As Date
     Dim v As Variant
     Dim strType As String
     
     Dim cFolders As Collection
     Dim olFolder As Outlook.Folder
     Dim subFolder As Folder

     

    Set olApp = New Outlook.Application
    Set olSession = olApp.GetNamespace("MAPI")
    'Set olStartFolder = olSession.PickFolder
    'Set mailitems = olStartFolder.Items

         Set cFolders = New Collection
        cFolders.Add Session.PickFolder
        Do While cFolders.Count > 0
            Set olFolder = cFolders(1)
            cFolders.Remove 1
            'Do something with the folder'
            For Each subFolder In olFolder.Folders
                cFolders.Add subFolder
            Next subFolder
        Loop
     
    ' Get Excel set up

     strPath = "C:\Users\A582335\Documents\ED test.xls"
         On Error Resume Next
         Set xlApp = GetObject(, "Excel.Application")
         If Err <> 0 Then
             Application.StatusBar = "Please wait while Excel source is opened ... "
             Set xlApp = CreateObject("Excel.Application")
             bXStarted = True
         End If
         On Error GoTo 0
         'Open the workbook to input the data
         Set xlWb = xlApp.Workbooks.Open(strPath)
         Set xlSheet = xlWb.Sheets("RawData")
        ' Process the message record
        
        On Error Resume Next
    'Find the next empty line of the worksheet
    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-14162).Row
     
     
    ' get the values from outlook
    Set currentExplorer = Application.ActiveExplorer
    Set Selection = currentExplorer.Selection
    For Each obj In Selection
    Set olItem = obj
    If olItem <> "nothing" Then

        'collect the fields
        strColA = olItem.SenderName
        strColB = olItem.CreationTime
        strColC = olItem.To
        strColD = olItem.Recipients
        strColE = olItem.ReceivedByName
        strColF = olItem.SentOn
        strColG = olItem.ReceivedTime
        strColH = olItem.UnRead
        strColI = olItem.LastModificationTime
        StrColJ = olItem.UserProperties
        StrColK = olItem.Categories
     

        'Add column Headers to the Excel Extract
          xlSheet.Range("A" & 1) = "Sender Name"
          xlSheet.Range("B" & 1) = "Creation Time"
          xlSheet.Range("C" & 1) = "Sent To"
          xlSheet.Range("D" & 1) = "Recipients"
          xlSheet.Range("E" & 1) = "Received By Name"
          xlSheet.Range("F" & 1) = "Sent On"
          xlSheet.Range("G" & 1) = "Received Time"
          xlSheet.Range("H" & 1) = "UnRead"
          xlSheet.Range("I" & 1) = "Last Modification Time"
          xlSheet.Range("J" & 1) = "User Properties"
          xlSheet.Range("K" & 1) = "Categories"
          xlSheet.Range("L" & 1) = "Last Verb Executed"
          xlSheet.Range("M" & 1) = "Last Verb Executed Time"
         
        'write them in the excel sheet
          xlSheet.Range("A" & rCount) = strColA
          xlSheet.Range("B" & rCount) = strColB
          xlSheet.Range("C" & rCount) = strColC
          xlSheet.Range("D" & rCount) = strColD
          xlSheet.Range("E" & rCount) = strColE
          xlSheet.Range("F" & rCount) = strColF
          xlSheet.Range("G" & rCount) = strColG
          xlSheet.Range("H" & rCount) = strColH
          xlSheet.Range("I" & rCount) = strColI
          xlSheet.Range("J" & rCount) = StrColJ
          xlSheet.Range("K" & rCount) = StrColK
          xlSheet.Range("L" & rCount) = StrColL
          xlSheet.Range("M" & rCount) = StrColM
     
          'Next row
          rCount = rCount + 1
    End If
    Next
     
         xlWb.Save
        
         xlWb.Close 1
         If bXStarted Then
             xlApp.Quit
         End If
        
         Set olItem = Nothing
         Set obj = Nothing
         Set currentExplorer = Nothing
         Set xlApp = Nothing
         Set xlWb = Nothing
         Set xlSheet = Nothing
        
     MsgBox ("All RM Group Emails exported to Excel..........")
     End Sub

    Thursday, July 21, 2016 7:42 PM
  • It seems you missed the line 'Do something with the folder? That's where your processing goes.

    The following should work providing that the folder exists in strpath.

    Why are you creating a new Outlook application when you are already running in Outlook?

    I have commented out a couple of your values as you have not configured them

    Option Explicit
    Sub CopyToExcel()
    Dim xlApp As Object
    Dim xlWb As Object
    Dim xlSheet As Object
    Dim rCount As Long
    Dim bXStarted As Boolean
    Dim enviro As String
    Dim strPath As String
    Dim olStartFolder As Outlook.MAPIFolder
    Dim mailitems As Outlook.Items
    Dim currentExplorer As Explorer
    Dim Selection As Selection
    Dim olItem As Outlook.MailItem
    Dim obj As Object
    Dim strColA, strColB, strColC, strColD, strColE, strColF, strColG, strColH, strColI, StrColJ, StrColK, StrColL, StrColM As String
    Dim LDate As Date
    Dim propertyAccessor As Outlook.propertyAccessor
    Dim PropName As String
    Dim LVE As String
    Dim LVET As String    'Date
    Dim dtUTC As Date
    Dim dtLocal As Date
    Dim v As Variant
    Dim strType As String

    Dim cFolders As Collection
    Dim olFolder As Outlook.Folder
    Dim subFolder As Folder



        'Set olStartFolder = olSession.PickFolder
        'Set mailitems = olStartFolder.Items

        ' Get Excel set up

        strPath = "C:\Users\A582335\Documents\ED test.xlsx"
        On Error Resume Next
        Set xlApp = GetObject(, "Excel.Application")
        If Err <> 0 Then
            Set xlApp = CreateObject("Excel.Application")
            bXStarted = True
        End If
        On Error GoTo 0
        'Open the workbook to input the data
        Set xlWb = xlApp.Workbooks.Add    '.Open(strPath)
        xlApp.Visible = True
        Set xlSheet = xlWb.Sheets("Sheet1")
        xlSheet.Name = "Raw Data"

        'Add column Headers to the Excel Extract
        xlSheet.Range("A" & 1) = "Sender Name"
        xlSheet.Range("B" & 1) = "Creation Time"
        xlSheet.Range("C" & 1) = "Sent To"
        xlSheet.Range("D" & 1) = "Recipients"
        xlSheet.Range("E" & 1) = "Received By Name"
        xlSheet.Range("F" & 1) = "Sent On"
        xlSheet.Range("G" & 1) = "Received Time"
        xlSheet.Range("H" & 1) = "UnRead"
        xlSheet.Range("I" & 1) = "Last Modification Time"
        xlSheet.Range("J" & 1) = "User Properties"
        xlSheet.Range("K" & 1) = "Categories"
        'xlSheet.Range("L" & 1) = "Last Verb Executed"
        'xlSheet.Range("M" & 1) = "Last Verb Executed Time"


        On Error Resume Next
        'Find the next empty line of the worksheet
        rCount = 2

        Set cFolders = New Collection
        cFolders.Add Session.PickFolder
        Do While cFolders.Count > 0
            Set olFolder = cFolders(1)
            cFolders.Remove 1
            'Do something with the folder'
            For Each olItem In olFolder.Items
                If olItem <> "nothing" Then

                    'collect the fields
                    strColA = olItem.SenderName
                    strColB = olItem.CreationTime
                    strColC = olItem.To
                    strColD = olItem.Recipients
                    strColE = olItem.ReceivedByName
                    strColF = olItem.SentOn
                    strColG = olItem.ReceivedTime
                    strColH = olItem.UnRead
                    strColI = olItem.LastModificationTime
                    StrColJ = olItem.UserProperties
                    StrColK = olItem.categories

                    'write them in the excel sheet
                    xlSheet.Range("A" & rCount) = strColA
                    xlSheet.Range("B" & rCount) = strColB
                    xlSheet.Range("C" & rCount) = strColC
                    xlSheet.Range("D" & rCount) = strColD
                    xlSheet.Range("E" & rCount) = strColE
                    xlSheet.Range("F" & rCount) = strColF
                    xlSheet.Range("G" & rCount) = strColG
                    xlSheet.Range("H" & rCount) = strColH
                    xlSheet.Range("I" & rCount) = strColI
                    xlSheet.Range("J" & rCount) = StrColJ
                    xlSheet.Range("K" & rCount) = StrColK
                    'xlSheet.Range("L" & rCount) = StrColL '
                    'xlSheet.Range("M" & rCount) = StrColM

                    'Next row
                    rCount = rCount + 1
                End If
                DoEvents
            Next olItem
            For Each subFolder In olFolder.folders
                cFolders.Add subFolder
            Next subFolder
        Loop

        xlWb.SaveAs strPath

        xlWb.Close 1
        If bXStarted Then
            xlApp.Quit
        End If

        Set olItem = Nothing
        Set obj = Nothing
        Set currentExplorer = Nothing
        Set xlApp = Nothing
        Set xlWb = Nothing
        Set xlSheet = Nothing

        MsgBox ("All RM Group Emails exported to Excel..........")
    End Sub



    Graham Mayor - Word MVP
    www.gmayor.com

    Friday, July 22, 2016 6:02 AM
  • Thanks Graham,

    Much appreciated. This now runs through all the relevant sub folders but after a certain time keeps looping if the folders have over 10,000 emails. Given the size of the mailboxes, is there anyway I can fine tune this so it doesn't keep looping with the these big folders? Is it possible to add a date range function to help with this and still go through all the relevant parent and sub folders?

    Regards,

    Ed

    Friday, July 22, 2016 9:30 AM
  • Anyone assist with this?
    Wednesday, July 27, 2016 7:33 AM
  • You can limit to a range of dates - the following limits to the last 7 days (iDays) or you could change the data comparison to give you what you need. I have removed the unuused items from your original code.
    Option Explicit
    
    Sub CopyToExcel()
    Dim xlApp As Object
    Dim xlWb As Object
    Dim xlSheet As Object
    Dim rCount As Long
    Dim bXStarted As Boolean
    Dim strPath As String
    Dim mailItems As Outlook.Items
    Dim olItem As Outlook.MailItem
    Dim i As Long
    Dim cFolders As Collection
    Dim olFolder As Outlook.Folder
    Dim subFolder As Folder
    Dim iDays As Long: iDays = 7
    
        strPath = "C:\Users\A582335\Documents\ED test.xlsx"
        On Error Resume Next
        Set xlApp = GetObject(, "Excel.Application")
        If Err <> 0 Then
            Set xlApp = CreateObject("Excel.Application")
            bXStarted = True
        End If
        On Error GoTo 0
        
        Set xlWb = xlApp.Workbooks.Add
        xlApp.Visible = True
        Set xlSheet = xlWb.Sheets("Sheet1")
        xlSheet.Name = "Raw Data"
    
        xlSheet.Range("A" & 1) = "Sender Name"
        xlSheet.Range("B" & 1) = "Creation Time"
        xlSheet.Range("C" & 1) = "Sent To"
        xlSheet.Range("D" & 1) = "Recipients"
        xlSheet.Range("E" & 1) = "Received By Name"
        xlSheet.Range("F" & 1) = "Sent On"
        xlSheet.Range("G" & 1) = "Received Time"
        xlSheet.Range("H" & 1) = "UnRead"
        xlSheet.Range("I" & 1) = "Last Modification Time"
        xlSheet.Range("J" & 1) = "User Properties"
        xlSheet.Range("K" & 1) = "Categories"
    
    
        On Error Resume Next
        rCount = 2
    
        Set cFolders = New Collection
        cFolders.Add Session.PickFolder
        Do While cFolders.Count > 0
            Set olFolder = cFolders(1)
            Set mailItems = olFolder.Items
            mailItems.Sort "[SentOn]", True
            cFolders.Remove 1
            For i = 1 To mailItems.Count
                Set olItem = mailItems(i)
                If Not olItem Is Nothing Then
                    If Format(olItem.ReceivedTime, "yyyymmdd") >= _
                       Format(Date - iDays, "yyyymmdd") Then
                        With olItem
                            xlSheet.Range("A" & rCount) = .SenderName
                            xlSheet.Range("B" & rCount) = .CreationTime
                            xlSheet.Range("C" & rCount) = .To
                            xlSheet.Range("D" & rCount) = .Recipients
                            xlSheet.Range("E" & rCount) = .ReceivedByName
                            xlSheet.Range("F" & rCount) = .SentOn
                            xlSheet.Range("G" & rCount) = .ReceivedTime
                            xlSheet.Range("H" & rCount) = .UnRead
                            xlSheet.Range("I" & rCount) = .LastModificationTime
                            xlSheet.Range("J" & rCount) = .UserProperties
                            xlSheet.Range("K" & rCount) = .categories
                        End With
                        rCount = rCount + 1
                    Else
                        Exit For
                    End If
                End If
                DoEvents
            Next i
            For Each subFolder In olFolder.folders
                cFolders.Add subFolder
            Next subFolder
        Loop
    
        xlWb.SaveAs strPath
    
        xlWb.Close 1
        If bXStarted Then
            xlApp.Quit
        End If
    
        Set olItem = Nothing
        Set xlApp = Nothing
        Set xlWb = Nothing
        Set xlSheet = Nothing
        Set mailItems = Nothing
        Set olFolder = Nothing
    
        MsgBox ("All RM Group Emails exported to Excel..........")
    End Sub
    


    Graham Mayor - Word MVP
    www.gmayor.com

    Wednesday, July 27, 2016 12:17 PM
  • Thank you.

    can the end user decide the date range by selecting start and end date?

    Also, do you know what the code is for to return the folder name of where the email is currently stored in? I like to use this to proof that all emails are being retrieved and easily build on from the raw data output to perform some metrics reporting on this.

    Next steps is identifying based on emails received, how many touchpoints it took to close out the inquiry and time span it took to respond to each touchpoint. I will utilize VBA in excel to perform majority of this review for me.

    thanks,

    ed

    Thursday, July 28, 2016 9:42 PM
  • The user can select a start and end date and you can modify the line

    If Format(olItem.ReceivedTime, "yyyymmdd") >= _
                       Format(Date - iDays, "yyyymmdd") Then

    to establish whether olitem.received time is after the start date and before the end date.

    The current folder name is olFolder.Name


    Graham Mayor - Word MVP
    www.gmayor.com

    Friday, July 29, 2016 4:45 AM
  • Hi Graham,

    I try adapting the above but I couldn't get a pop up box to provide end user option. I tried putting the below in but don't know where I need to put this into the code so that end user only has to determine date range once:

    InputBox("Enter the date range of the messages to export in the form ""mm/dd/yyyy to mm/dd/yyyy""", MACRO_NAME, Date & " to " & Date)

    also, for the folder path for each email, you specify how I write that into the above code?

    Many Thanks,

    Ed

    Sunday, July 31, 2016 11:03 AM
  • You must prompt for each date and feed that into the macro e.g. as follows. I have also added the folder path.

    Option Explicit

    Sub CopyToExcel()
    Dim xlApp As Object
    Dim xlWb As Object
    Dim xlSheet As Object
    Dim rCount As Long
    Dim bXStarted As Boolean
    Dim strPath As String
    Dim mailItems As Outlook.Items
    Dim olItem As Outlook.MailItem
    Dim i As Long
    Dim cFolders As Collection
    Dim olFolder As Outlook.Folder
    Dim subFolder As Folder
    Dim iDays As Long: iDays = 7
    Dim strStartDate As String
    Dim strEndDate As String

        strPath = Environ("USERPROFILE") & "\Documents\ED test.xlsx"

        strStartDate = InputBox("Enter the latest date", "Start Date", Format(Date, "Short Date"))
        If Not IsDate(strStartDate) Then
            If strStartDate = "" Then
                MsgBox "No date selected, or user cancelled"
            Else
                MsgBox strStartDate & " is invalid"
            End If
            GoTo lbl_Exit
        End If

        strEndDate = InputBox("Enter the earliest date", "End Date", Format(Date - iDays, "Short Date"))
        If Not IsDate(strEndDate) Then
            If strEndDate = "" Then
                MsgBox "No date selected, or user cancelled"
            Else
                MsgBox strEndDate & " is invalid"
            End If
            GoTo lbl_Exit
        End If

        On Error Resume Next
        Set xlApp = GetObject(, "Excel.Application")
        If Err <> 0 Then
            Set xlApp = CreateObject("Excel.Application")
            bXStarted = True
        End If
        On Error GoTo 0

        Set xlWb = xlApp.Workbooks.Add
        xlApp.Visible = True
        Set xlSheet = xlWb.Sheets("Sheet1")
        xlSheet.Name = "Raw Data"

        xlSheet.Range("A" & 1) = "Sender Name"
        xlSheet.Range("B" & 1) = "Creation Time"
        xlSheet.Range("C" & 1) = "Sent To"
        xlSheet.Range("D" & 1) = "Recipients"
        xlSheet.Range("E" & 1) = "Received By Name"
        xlSheet.Range("F" & 1) = "Sent On"
        xlSheet.Range("G" & 1) = "Received Time"
        xlSheet.Range("H" & 1) = "UnRead"
        xlSheet.Range("I" & 1) = "Last Modification Time"
        xlSheet.Range("J" & 1) = "User Properties"
        xlSheet.Range("K" & 1) = "Categories"
        xlSheet.Range("L" & 1) = "Folder"



        On Error Resume Next
        rCount = 2

        Set cFolders = New Collection
        cFolders.Add Session.PickFolder
        Do While cFolders.Count > 0
            Set olFolder = cFolders(1)
            Set mailItems = olFolder.Items
            mailItems.Sort "[SentOn]", True
            cFolders.Remove 1
            For i = 1 To mailItems.Count
                Set olItem = mailItems(i)
                If Not olItem Is Nothing Then
                    If Format(olItem.ReceivedTime, "yyyymmdd") <= _
                       Format(CDate(strStartDate), "yyyymmdd") And _
                       Format(olItem.ReceivedTime, "yyyymmdd") >= _
                       Format(CDate(strEndDate), "yyyymmdd") Then

                        With olItem
                            xlSheet.Range("A" & rCount) = .SenderName
                            xlSheet.Range("B" & rCount) = .CreationTime
                            xlSheet.Range("C" & rCount) = .To
                            xlSheet.Range("D" & rCount) = .Recipients
                            xlSheet.Range("E" & rCount) = .ReceivedByName
                            xlSheet.Range("F" & rCount) = .SentOn
                            xlSheet.Range("G" & rCount) = .ReceivedTime
                            xlSheet.Range("H" & rCount) = .UnRead
                            xlSheet.Range("I" & rCount) = .LastModificationTime
                            xlSheet.Range("J" & rCount) = .UserProperties
                            xlSheet.Range("K" & rCount) = .categories
                            xlSheet.Range("K" & rCount) = olFolder.FolderPath
                        End With
                        rCount = rCount + 1
                    Else
                        Exit For
                    End If
                End If
                DoEvents
            Next i
            For Each subFolder In olFolder.folders
                cFolders.Add subFolder
            Next subFolder
        Loop

        xlWb.SaveAs strPath

        xlWb.Close 1
        If bXStarted Then
            xlApp.Quit
        End If
        MsgBox ("All RM Group Emails exported to Excel..........")
    lbl_Exit:
        Set olItem = Nothing
        Set xlApp = Nothing
        Set xlWb = Nothing
        Set xlSheet = Nothing
        Set mailItems = Nothing
        Set olFolder = Nothing
        Exit Sub
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com

    Monday, August 1, 2016 6:00 AM
  • Hi Graham

    Your a genius!

    I'm now able to pull the info exactly like I need it. The only thing I notice that its very slow in extracting the information. Just wondering any quick fix in speeding this up? At the moment I see it updating line by line when exporting to excel.

    Really appreciate your help to date though as you have now made it possible for me to bring this raw date to Excel and bring it to life! :)

    Thank You again.Ed

    Monday, August 1, 2016 7:34 PM
  • It's much quicker than doing it manually :)

    Graham Mayor - Word MVP
    www.gmayor.com

    Tuesday, August 2, 2016 4:33 AM
  • :)...true

    think I got too excited yesterday though. :(

    I see when I put a start and end date at the beginning of July to retrieve the emails it doesn't retrieve all the emails and only returns about 1% of them. I notice that if the start and end date is yesterday it works fine but if I push this back to any earlier date, the macro runs into problems in retrieving the information.

    should there be a mechanism first whereby it should retain the data and then write whatever is applicable based on the date range? It just seems the older the email is, the harder for the macro is to find it?

    appreciate your help.

    regards,

    ed.

    Tuesday, August 2, 2016 7:12 AM
  • from what I can see Graham, when the receive date is after the start date and before the end date, when it loops to the relevant folder, it checks the first email in that folder and if the date on that email is outside the date range given it skips that folder then?? not an issue when selecting todays date as will loop through everything then.

    also noticed that even though you pick a mailbox to search, I see when I step through the code, it still quickly loops through all the other folders outside of that mailbox also? don't know why it does that if you told it what mailbox to review, i.e. it lopps though "journals" in my personal mailbox, when I chose the shared mailbox to search.

    appreciate any help you can give to tidy this up?

    Tuesday, August 2, 2016 8:03 PM
  • Hmmm. If you replace

    Else
       Exit For

    with

    ElseIf Format(olItem.ReceivedTime, "yyyymmdd") <= _
                           Format(CDate(strEndDate), "yyyymmdd") Then
          Exit For

    The premature ending shoud be corrected.

    I noticed a typo in the code.

    xlSheet.Range("K" & rCount) = olFolder.FolderPath

    should be

    xlSheet.Range("L" & rCount) = olFolder.FolderPath
    The macro should process the selected folder and all its sub folders. It should not wander off to other parent folders.



    Graham Mayor - Word MVP
    www.gmayor.com


    Wednesday, August 3, 2016 5:46 AM
  • Hi Graham,

    I'm happy to say this query appears to be answered.

    Many Thanks....can't thank you enough,

    Ed

    Sunday, August 7, 2016 5:48 PM
  • Hi Graham,

    Merry Christmas and Happy new year.

    Just wanted to follow up on the above code. Wondering if you can help me put some error handling on this code around the below bolded/underlined sections as when the user presses cancel, code keeps running in the background despite it having no instruction to do so.

    additionally, this code crashes my computer on occasions despite everything running as it should do. I run this daily so I would say the occurrence of it crashing happens 10% of the time. I just need to run task manager to close the app down to re-launch again. Any reason why this would happen?

    appreciate all your help.

    regards,

    ed

    Option Explicit

     Sub CopyToExcel()
     Dim xlApp As Object
     Dim xlWb As Object
     Dim xlSheet As Object
     Dim rCount As Long
     Dim bXStarted As Boolean
     Dim strPath As String
     Dim mailItems As Outlook.Items
     Dim olItem As Outlook.MailItem
     Dim i As Long
     Dim cFolders As Collection
     Dim olExchgnUser    As ExchangeUser
     Dim olFolder As Outlook.Folder
     Dim subFolder As Folder
     Dim iDays As Long: iDays = 7
     Dim strStartDate As String
     Dim strEndDate As String

         strPath = Environ("USERPROFILE") & "R:\FACSAPPS\FA\CUS\CRPACT\ED test.xlsx"

         strStartDate = InputBox("Enter the latest date", "Start Date", Format(Date, "Short Date"))
         If Not IsDate(strStartDate) Then
             If strStartDate = "" Then
                 MsgBox "No date selected, or user cancelled"
             Else
                 MsgBox strStartDate & " is invalid"
             End If
             GoTo lbl_Exit
         End If

         strEndDate = InputBox("Enter the earliest date", "End Date", Format(Date - iDays, "Short Date"))
         If Not IsDate(strEndDate) Then
             If strEndDate = "" Then
                 MsgBox "No date selected, or user cancelled"
             Else
                 MsgBox strEndDate & " is invalid"
             End If
             GoTo lbl_Exit
         End If

         On Error Resume Next
         Set xlApp = GetObject(, "Excel.Application")
         If Err <> 0 Then
             Set xlApp = CreateObject("Excel.Application")
             bXStarted = True
         End If
         On Error GoTo 0

         Set xlWb = xlApp.Workbooks.Add
         xlApp.Visible = True
         Set xlSheet = xlWb.Sheets("Sheet1")
         xlSheet.Name = "Raw Data"

         xlSheet.Range("A" & 1) = "Sender Name"
         'xlSheet.Range("B" & 1) = "Creation Time"
         xlSheet.Range("B" & 1) = "Sent To"
         'xlSheet.Range("D" & 1) = "Recipients"
         'xlSheet.Range("E" & 1) = "Received By Name"
         xlSheet.Range("C" & 1) = "Sent On"
         'xlSheet.Range("G" & 1) = "Received Time"
         xlSheet.Range("D" & 1) = "subject"
         'xlSheet.Range("I" & 1) = "index"
         xlSheet.Range("E" & 1) = "Conversation"
         xlSheet.Range("F" & 1) = "Categories"
         xlSheet.Range("G" & 1) = "Folder"

         On Error Resume Next
         rCount = 2

         Set cFolders = New Collection
         cFolders.Add Session.PickFolder
         Do While cFolders.Count > 0
             Set olFolder = cFolders(1)
             Set mailItems = olFolder.Items
             mailItems.Sort "[SentOn]", True
             cFolders.Remove 1
             For i = 1 To mailItems.Count
                 Set olItem = mailItems(i)
                 If Not olItem Is Nothing Then
                     If Format(olItem.ReceivedTime, "yyyymmdd") <= _
                        Format(CDate(strStartDate), "yyyymmdd") And _
                        Format(olItem.ReceivedTime, "yyyymmdd") >= _
                        Format(CDate(strEndDate), "yyyymmdd") Then

                         With olItem
                             xlSheet.Range("A" & rCount) = .SenderName
                             'xlSheet.Range("B" & rCount) = .CreationTime
                             xlSheet.Range("B" & rCount) = .To
                             'xlSheet.Range("D" & rCount) = .Recipients
                             'xlSheet.Range("E" & rCount) = .ReceivedByName
                             xlSheet.Range("C" & rCount) = .SentOn
                             'xlSheet.Range("G" & rCount) = .ReceivedTime
                             xlSheet.Range("D" & rCount) = .Subject
                             'xlSheet.Range("I" & rCount) = .ConversationIndex
                             xlSheet.Range("E" & rCount) = .ConversationTopic
                             xlSheet.Range("F" & rCount) = .Categories
                             xlSheet.Range("G" & rCount) = olFolder.FolderPath
                             xlSheet.Range("H" & rCount) = olExchgnUser.JobTitle
                             xlSheet.Range("I" & rCount) = olExchgnUser.Department
                         End With
                         rCount = rCount + 1
                    ElseIf Format(olItem.ReceivedTime, "yyyymmdd") <= _
                           Format(CDate(strEndDate), "yyyymmdd") Then
          Exit For
                     End If
                 End If
                 DoEvents
             Next i
             For Each subFolder In olFolder.Folders
                 cFolders.Add subFolder
             Next subFolder
         Loop

         xlWb.SaveAs strPath

         xlWb.Close 1
         If bXStarted Then
             xlApp.Quit
         End If
         MsgBox ("All RM Group Emails exported to Excel..........")
    lbl_Exit:
         Set olItem = Nothing
         Set xlApp = Nothing
         Set xlWb = Nothing
         Set xlSheet = Nothing
         Set mailItems = Nothing
         Set olFolder = Nothing
         Exit Sub
     End Sub

    Friday, December 30, 2016 7:52 AM
  • A Happy New Year to you also.

    There are some issues with your code. The most immediately obvious being that

    Environ("USERPROFILE") & "R:\FACSAPPS\FA\CUS\CRPACT\ED test.xlsx" is not a valid path. On the face of it, it should be

     "R:\FACSAPPS\FA\CUS\CRPACT\ED test.xlsx"

    The path "R:\FACSAPPS\FA\CUS\CRPACT\" should exist. If it doesn't it needs to be created, so in the same module add the following function and call it from a new line in the main code before the workbook is saved. i.e. Change

    strPath = Environ("USERPROFILE") & "R:\FACSAPPS\FA\CUS\CRPACT\ED test.xlsx"

    to

    strPath = "R:\FACSAPPS\FA\CUS\CRPACT\"
    CreateFolders strPath
    strPath = strPath &
    "ED test.xlsx"

    If the folder already exists the function doesn't do anything. However if the R drive is not available, this will also crash the system. I suspect that your crashes are related to the invalid path. If there is a possibility that R, which I assume is a mapped network drive, is not going to be available, you will have to trap that also, or work with a local path instead.

    Private Function CreateFolders(strPath As String)
    'An Office macro by Graham Mayor - www.gmayor.com
    Dim strTempPath As String
    Dim lngPath As Long
    Dim vPath As Variant
    Dim oFSO As Object
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        vPath = Split(strPath, "\")
        strPath = vPath(0) & "\"
        For lngPath = 1 To UBound(vPath)
            strPath = strPath & vPath(lngPath) & "\"
            If Not oFSO.FolderExists(strPath) Then MkDir strPath
        Next lngPath
    lbl_Exit:
        Set oFSO = Nothing
        Exit Function
    End Function


    Add

    Dim olRootFolder As Outlook.Folder

    to the variable declarations

    then add to or change the following section where indicated

        Set xlWb = xlApp.Workbooks.Add
        xlApp.Visible = True
        Set xlSheet = xlWb.Sheets("Sheet1")
        xlSheet.Name = "Raw Data"

        xlSheet.Range("A" & 1) = "Sender Name"
        xlSheet.Range("B" & 1) = "Sent To"
        xlSheet.Range("C" & 1) = "Sent On"
        xlSheet.Range("D" & 1) = "subject"
        xlSheet.Range("E" & 1) = "Conversation"
        xlSheet.Range("F" & 1) = "Categories"
        xlSheet.Range("G" & 1) = "Folder"
        xlSheet.Range("H" & 1) = "Job Title"
        xlSheet.Range("I" & 1) = "Department"
        On Error Resume Next
        rCount = 2

        Set cFolders = New Collection
        Set olRootFolder = Session.PickFolder
        If olRootFolder = "" Then
             MsgBox "User cancelled"
            xlWb.Close 0
            If bXStarted Then
                xlApp.Quit
            End If
            GoTo lbl_Exit
        End If
        cFolders.Add olRootFolder
        Do While cFolders.Count > 0



    Graham Mayor - Word MVP
    www.gmayor.com


    • Edited by Graham MayorMVP Sunday, January 1, 2017 5:30 AM
    • Marked as answer by Ed McArdle Wednesday, January 4, 2017 8:39 AM
    Sunday, January 1, 2017 5:19 AM
  • If for someone Grahams code is to hard, I recommend a free add-in to export all columns to CSV files from Outlook folder (for selection or all items): CodeTwo Outlook Export

    Regards.


    Oskar Shon, Office System MVP - www.VBATools.pl
    if Helpful; Answer when a problem solved

    • Marked as answer by Ed McArdle Wednesday, January 4, 2017 8:37 AM
    • Unmarked as answer by Ed McArdle Wednesday, January 4, 2017 8:39 AM
    Monday, January 2, 2017 9:05 AM
    Answerer
  • Thanks so much,

    answer above clearly laid out. I removed reference to the file path and just have the user save the file new each time. also added the other error handling so this brings it to full loop.

    appreciate your help as always.

    regards,

    ed

    Wednesday, January 4, 2017 8:20 AM
  • Hi Oskar,

    Thanks for that. Unfortunately the above only captures one folder at a time. I needed something to capture all activity within a mailbox for a defined date range.

    Appreciate the help.

    regards,

    Oskar

    Wednesday, January 4, 2017 8:40 AM