Run Macro on More Than One Outlook Message RRS feed

  • Question

  • <p>I need to copy over email content from an online form to an excel spreadsheet. I have a macro set up that appears ot be working, but when i select all the messages, it only copies over the last email selected. Also i need all info, even if some emails only have 1of2/2of3 fields answered. The fields in the all of the email are as followed:




    The code i am using is:

    Option Explicit

    Sub CopyToExcel()
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim olItem As Outlook.MailItem
    Dim vText As Variant
    Dim sText As String
    Dim vItem As Variant
    Dim i As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Const strPath As String = "c:\users\jianna\My Documents\Emails.xlsx" 'the path of the workbook

    If Application.ActiveExplorer.Selection.Count = 0 Then
        MsgBox "No Items selected!", vbCritical, "Error"
        Exit Sub
    End If
    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("Sheet1")

    'Process each selected record
    For Each olItem In Application.ActiveExplorer.Selection
        sText = olItem.Body
        vText = Split(sText, Chr(13))
        'Find the next empty line of the worksheet
       rCount = xlSheet.UsedRange.Rows.Count
        rCount = rCount + 1

        'Check each line of text in the message body
        For i = UBound(vText) To 0 Step -1
            If InStr(1, vText(i), "Message:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("A" & rCount) = Trim(vItem(1))
            End If

            If InStr(1, vText(i), "From:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("B" & rCount) = Trim(vItem(1))
            End If

            If InStr(1, vText(i), "Phone:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("C" & rCount) = Trim(vItem(1))
            End If

        Next i
    Next olItem
    xlWB.Close SaveChanges:=True
    If bXStarted Then
    End If
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
    Set olItem = Nothing
    End Sub

    Thanks for your help!

    Monday, July 14, 2014 7:43 PM


  • How far I understand, You can change line with:

    For Each olItem In Application.ActiveExplorer.Selection

    to all messages in folder

    Dim oFolder As MAPIFolder: oFolder = Application.ActiveExplorer.CurrentFolder

    For Each item In oFolder.Items

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

    • Marked as answer by danishani Tuesday, November 11, 2014 12:03 AM
    Tuesday, July 15, 2014 12:55 PM