none
Email extraction - Read and Unread RRS feed

  • Question

  • I'm extracting email from outlook to an existing excel file, so how do I know which email has already been exported?

    My current code will keep exporting the email even though it has already been exported.

    My code

    Sub ExportToExcel()
    On Error GoTo ErrHandler
    Dim appExcel As Object
    Dim wkb As Object
    Dim wks As Object
    Dim rng As Object
    Dim strSheet As String
    Dim strPath As String
    
    
    Dim intRowCounter As Integer
    Dim intColumnCounter As Integer
    Dim msg As Outlook.MailItem
            
    
    Dim nms As Outlook.NameSpace
    Dim fld As Outlook.MAPIFolder
    Dim itm As Object
    strSheet = "Vulnerability Advisory_2015.xlsx"
    strPath = "D:\"
    strSheet = strPath & strSheet
    Debug.Print strSheet   'Select export folder
    Set nms = Application.GetNamespace("MAPI")
    Set fld = nms.PickFolder   'Handle potential errors with Select Folder dialog box.
    If fld Is Nothing Then
    MsgBox "There are no mail messages to export", vbOKOnly, _
    "Error"
    Exit Sub
    ElseIf fld.DefaultItemType <> olMailItem Then
    MsgBox "There are no mail messages to export", vbOKOnly, _
    "Error"
    Exit Sub
    ElseIf fld.Items.Count = 0 Then
    MsgBox "There are no mail messages to export", vbOKOnly, _
    "Error"
    Exit Sub
    End If   'Open and activate Excel workbook.
    Set appExcel = CreateObject("Excel.Application")
    appExcel.Workbooks.Open (strSheet)
    Set wkb = appExcel.ActiveWorkbook
    Set wks = wkb.Sheets(1)
    
    wks.Activate
    
    appExcel.Application.Visible = True   'Copy field items in mail folder.
    intRowCounter = wks.UsedRange.Rows.Count
    For Each itm In fld.Items
    intColumnCounter = 1
    Set msg = itm
    intRowCounter = intRowCounter + 1
    intColumnCounter = intColumnCounter + 1
    wks.Rows(intRowCounter).Insert Shift:=xlup, CopyOrigin:=xlFormatFromLeftOrAbove
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    
    If msg.Subject Like "Request For Information REF:*" Then
        rng.Value = msg.Subject
        intColumnCounter = intColumnCounter + 1
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.ReceivedTime
        intColumnCounter = intColumnCounter + 2
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.Body
    End If
    Next itm
    Set appExcel = Nothing
    Set wkb = Nothing
    Set wks = Nothing
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set fld = Nothing
    Set itm = Nothing
    Exit Sub
    ErrHandler:  If Err.Number = 1004 Then
    MsgBox strSheet & " doesn't exist", vbOKOnly, _
    "Error"
    Else
    MsgBox Err.Number & "; Description: ", vbOKOnly, _
    "Error"
    End If
    Set appExcel = Nothing
    Set wkb = Nothing
    Set wks = Nothing
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set fld = Nothing
    Set itm = Nothing
    
    End Sub
    

    Tuesday, July 21, 2015 2:18 AM

Answers

  • Sub ExportMailsToExcel()
      'Constants from Excel used in this code:
      Const xlUp = -4162
      Const xlFormatFromLeftOrAbove = 0
      Const xlValues = -4163
      Const xlWhole = 1
    
      Dim xlApplication As Object 'Excel.Application
      Dim xlWorkbook As Object 'Excel.Workbook
      Dim xlWorksheet As Object 'Excel.Worksheet
      Dim xlRange As Object 'Excel.Range
    
      Dim ThisNameSpace As Outlook.NameSpace
      Dim ThisMAPIFolder As Outlook.MAPIFolder
      Dim ThisFolderItem As Object
      Dim ThisMailItem As Outlook.MailItem
      Dim Data
    
      'Access Excel
      On Error Resume Next
      Set xlApplication = GetObject(, "Excel.Application")
      If xlApplication Is Nothing Then
        MsgBox "Open the destination workbook first!"
        Exit Sub
      End If
      Set xlWorkbook = xlApplication.ActiveWorkbook
      If xlWorkbook Is Nothing Then
        MsgBox "Open the destination workbook first!"
        Exit Sub
      End If
      Set xlWorksheet = xlWorkbook.ActiveSheet
      On Error GoTo 0
      If MsgBox("Export to file '" & xlWorkbook.Name & "' worksheet '" & xlWorksheet.Name & "' ?", vbOKCancel) = vbCancel Then Exit Sub
    
      'Let the user pick a folder
      Set ThisNameSpace = Application.GetNamespace("MAPI")
      Set ThisMAPIFolder = ThisNameSpace.PickFolder
      'Aborted?
      If ThisMAPIFolder Is Nothing Then Exit Sub
      If ThisMAPIFolder.DefaultItemType <> olMailItem Or ThisMAPIFolder.Items.Count = 0 Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
        Exit Sub
      End If
    
      'Visit each item in this folder
      For Each ThisFolderItem In ThisMAPIFolder.Items
        'Is this a mail?
        If TypeOf ThisFolderItem Is Outlook.MailItem Then
          Set ThisMailItem = ThisFolderItem
          If ThisMailItem.Subject Like "Request For Information REF:*" Then
            'Search for the ID in the 1st column
            Set xlRange = xlWorksheet.Columns(1).Find(ThisMailItem.EntryID, LookIn:=xlValues, LookAt:=xlWhole)
            'Found?
            If Not xlRange Is Nothing Then GoTo SkipItem
            'Get next empty row below the data
            Set xlRange = xlWorksheet.Range("A" & xlWorksheet.Rows.Count).End(xlUp).Offset(1)
            'Collect the data into an array
            ReDim Data(1 To 4)
            Data(1) = ThisMailItem.EntryID
            Data(2) = ThisMailItem.Subject
            Data(3) = ThisMailItem.ReceivedTime
            Data(4) = ThisMailItem.Body
            xlRange.Resize(1, UBound(Data)) = Data
          End If
        End If
    SkipItem:
      Next
    End Sub
    

    • Proposed as answer by André Santo Tuesday, July 21, 2015 1:44 PM
    • Marked as answer by Derrick319 Wednesday, July 22, 2015 5:54 AM
    Tuesday, July 21, 2015 10:02 AM

All replies

  • You have to export the EntryID property of the MailItem too. Then you can search for it the next time and skip of already exists.

    Andreas.

    Tuesday, July 21, 2015 7:13 AM
  • Sub ExportMailsToExcel()
      'Constants from Excel used in this code:
      Const xlUp = -4162
      Const xlFormatFromLeftOrAbove = 0
      Const xlValues = -4163
      Const xlWhole = 1
    
      Dim xlApplication As Object 'Excel.Application
      Dim xlWorkbook As Object 'Excel.Workbook
      Dim xlWorksheet As Object 'Excel.Worksheet
      Dim xlRange As Object 'Excel.Range
    
      Dim ThisNameSpace As Outlook.NameSpace
      Dim ThisMAPIFolder As Outlook.MAPIFolder
      Dim ThisFolderItem As Object
      Dim ThisMailItem As Outlook.MailItem
      Dim Data
    
      'Access Excel
      On Error Resume Next
      Set xlApplication = GetObject(, "Excel.Application")
      If xlApplication Is Nothing Then
        MsgBox "Open the destination workbook first!"
        Exit Sub
      End If
      Set xlWorkbook = xlApplication.ActiveWorkbook
      If xlWorkbook Is Nothing Then
        MsgBox "Open the destination workbook first!"
        Exit Sub
      End If
      Set xlWorksheet = xlWorkbook.ActiveSheet
      On Error GoTo 0
      If MsgBox("Export to file '" & xlWorkbook.Name & "' worksheet '" & xlWorksheet.Name & "' ?", vbOKCancel) = vbCancel Then Exit Sub
    
      'Let the user pick a folder
      Set ThisNameSpace = Application.GetNamespace("MAPI")
      Set ThisMAPIFolder = ThisNameSpace.PickFolder
      'Aborted?
      If ThisMAPIFolder Is Nothing Then Exit Sub
      If ThisMAPIFolder.DefaultItemType <> olMailItem Or ThisMAPIFolder.Items.Count = 0 Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
        Exit Sub
      End If
    
      'Visit each item in this folder
      For Each ThisFolderItem In ThisMAPIFolder.Items
        'Is this a mail?
        If TypeOf ThisFolderItem Is Outlook.MailItem Then
          Set ThisMailItem = ThisFolderItem
          If ThisMailItem.Subject Like "Request For Information REF:*" Then
            'Search for the ID in the 1st column
            Set xlRange = xlWorksheet.Columns(1).Find(ThisMailItem.EntryID, LookIn:=xlValues, LookAt:=xlWhole)
            'Found?
            If Not xlRange Is Nothing Then GoTo SkipItem
            'Get next empty row below the data
            Set xlRange = xlWorksheet.Range("A" & xlWorksheet.Rows.Count).End(xlUp).Offset(1)
            'Collect the data into an array
            ReDim Data(1 To 4)
            Data(1) = ThisMailItem.EntryID
            Data(2) = ThisMailItem.Subject
            Data(3) = ThisMailItem.ReceivedTime
            Data(4) = ThisMailItem.Body
            xlRange.Resize(1, UBound(Data)) = Data
          End If
        End If
    SkipItem:
      Next
    End Sub
    

    • Proposed as answer by André Santo Tuesday, July 21, 2015 1:44 PM
    • Marked as answer by Derrick319 Wednesday, July 22, 2015 5:54 AM
    Tuesday, July 21, 2015 10:02 AM