Exporting Emails from Parent and SubFolders to Excel using VBA RRS feed

  • Question

  • Hi All

    I have a piece of code where I have had some help from this forum to export mails to Excel using VBA.  This code works perfectly well however I now need to export ALL mails from my Inbox and it's sub folders without having to highlight all of the mails in my Inbox first.  I spent about 5 hours last night trying to find a solution but failed miserably.  Any help would be appreciated.  My current code is below for information:

    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
    Set olApp = New Outlook.Application
    Set olSession = olApp.GetNamespace("MAPI")
    Set olStartFolder = olSession.PickFolder
    Set mailitems = olStartFolder.Items
    ' Get Excel set up
     strPath = "D:\Email Metrics\RM Group\test.xlsx"
         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
        LVE = ""
        'Obtain an instance of PropertyAccessor class
        Set propertyAccessor = olItem.propertyAccessor
        'Call GetProperty
        LVE = propertyAccessor.GetProperty(LVE)
        StrColL = LVE
        LVET = ""
        'Obtain an instance of PropertyAccessor class
        Set propertyAccessor = olItem.propertyAccessor
        'Call GetProperty
        v = propertyAccessor.GetProperty(LVET)
        'LVET = propertyAccessor.GetProperty(LVET)
        StrColM = v
        '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
         xlWb.Close 1
         If bXStarted Then
         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

    Kind regards



    Wednesday, December 2, 2015 8:53 AM


All replies