Macro to import Outlook Fields to Excel

Hi

I am trying to create a macro that collects the fields from each Outlook message in the selected Outlook folder and writes the values of the fields to an Excel worksheet.

The goal is from excel to be able to retrieved statical information in outlook by creating a link or a VBA.

EG. from - to - receive date - categories (if possible)


Thank you for sharing your knowledge.



Nick

trying to pull outlook data from excel is not likely to be easy since you're running into the security wall setup to help prevent people from writing macro viruses that steal email addresses into an excel file and then post the file somewhere nefarious.

However, pushing the data from Outlook to Excel tends to be a little easier under the assumtion that you're the only one who can get code to execute under your outlook session.

Const LogAfterDate As Date = #1/1/2015#
Private Sub LogActiveFolder()
    Const LogPath As String = ""
    Dim fldr As MAPIfolder, itm As Object, str As String
    
    Dim exApp As Excel.Application
    Set exApp = CreateObject("Excel.Application")
    'Dim wb As Excel.Workbook
    'Set wb = exApp.Workbooks.Open(FileName:=logpath, UpdateLinks:=False, ReadOnly:=False, AddToMru:=False)
    Dim ws As Excel.Worksheet
    Set ws = exApp.Workbooks.Add.Worksheets(1)
    ws.Cells(1, 1).Value = "Path"
    ws.Cells(1, 2).Value = "Type"
    ws.Cells(1, 3).Value = "Sender"
    ws.Cells(1, 4).Value = "Receiver"
    ws.Cells(1, 5).Value = "Sent"
    ws.Cells(1, 6).Value = "Received"
    ws.Cells(1, 7).Value = "Subject"
    ws.Cells(1, 8).Value = "Folder"
    
    RecurseDir ActiveExplorer.CurrentFolder, ws.Cells(2, 1)
    exApp.Visible = True
    
End Sub

Private Function RecurseDir(Foldr As Outlook.MAPIfolder, rng As Range) As Range
    Dim typItm As Outlook.AppointmentItem
    Dim itm As Object, i As Long
    i = 0
    For Each itm In Foldr.Items
        If itm.ReceivedTime < LogAfterDate Then GoTo SkipItm
        'If InStr(itm.BillingInformation, "Done") Then GoTo SkipItm
        rng.Offset(i, 0).Value = Foldr.FolderPath
        Select Case itm.Class
         Case olMail
            rng.Offset(i, 1).Value = "Email"
            rng.Offset(i, 2).Value = itm.SenderName
            rng.Offset(i, 3).Value = itm.ReceivedByName
            rng.Offset(i, 4).Value = itm.SentOn
            rng.Offset(i, 5).Value = itm.ReceivedTime
         Case olMeetingRequest, olMeetingCancellation, olMeetingResponseNegative, olMeetingResponsePositive, olMeetingResponseTentative
            Select Case itm.Class
             Case olMeetingRequest
                rng.Offset(i, 1).Value = "Meeting:Request"
             Case olMeetingCancellation
                rng.Offset(i, 1).Value = "Meeting:Cancellation"
             Case olMeetingResponseNegative
                rng.Offset(i, 1).Value = "Meeting:Declined"
             Case olMeetingResponsePositive
                rng.Offset(i, 1).Value = "Meeting:Accepted"
             Case olMeetingResponseTentative
                rng.Offset(i, 1).Value = "Meeting:Tentative"
            End Select
            rng.Offset(i, 2).Value = itm.SenderName
            rng.Offset(i, 4).Value = itm.SentOn
            rng.Offset(i, 5).Value = itm.ReceivedTime
         Case olAppointment
            rng.Offset(i, 1).Value = "Appointment"
            rng.Offset(i, 2).Value = itm.Organizer
         Case olReport
            rng.Offset(i, 1).Value = "Report"
         Case Else
            rng.Offset(i, 1).Value = "Unknown At Index:" & i
        End Select
        rng.Offset(i, 6).Value = itm.Subject
        rng.Offset(i, 7).Value = Foldr.Name
        'itm.BillingInformation = itm.BillingInformation & ",Done"
        'itm.Save
        i = i + 1
SkipItm: Next itm
    Set RecurseDir = rng.Offset(i, 0)
    
    Dim f As Outlook.MAPIfolder
    On Error Resume Next
    For Each f In Foldr.Folders
        Set RecurseDir = RecurseDir(f, RecurseDir)
    Next f
    On Error GoTo 0
End Function