Exporting Email Body Text to excel (using outlook 2010) VBA

  • Re: Exporting Email Body Text to excel (using outlook 2010) VBA


    Right for some strange reason it is now working,


    i just dragged an email into the british gas folder and it now works,


    wierd,



    Anyway Many thanks for your help :)

  • Re: Exporting Email Body Text to excel (using outlook 2010) VBA


    Okay, first off, this is my first VBA code ever. So I know some of it might be in accurate so bear with me while i'm learning.


    This is what the email looks like whenever I receive it:
    Employee Creation
    Login Account Name: FirstName.LastName
    User: Last, First
    Employee Number: XXXXXX
    SalesRep ID/Tech ID: XXXXX
    Login: XXXXXXXX
    Employment Type: Employee
    Title: CCR I - Tech Support
    What i'm trying to do is get the Account Name, Number, Sales ID, and Login to copy in to a worksheet that already has column headers. I need each email to be on one row under the designated Header, i.e. Account Name. I have tried all sorts of code and I can get the spreadsheet to open and auto save but it doesn't put any of the information from the email in the spreadsheet. I'm so frustrated with this! I thought I had it fixed but no. LOL


    Here is my code. I've been trying to fix this for like 2 weeks now. I'm using Microsoft Outlook 2010 and Excel 2010.


    Sub NewHires()
    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 Row As Variant
    Dim bXStarted As Boolean
    Const strPath As String = "X:\ETX\Departments\CC-NewHireInformation\2013\November 2013\IN PROCESS - New Hires Spreadsheet_11.09.13_MDS_ASVS.xlsm" '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("Raw Data")
    '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 = Sheet1.cells(Row.Count, 1).Offset(1, 0)

    'Check each line of text in the message body
    For i = UBound(vText) To 0 Step -1
    If InStr(1, vText(i), "Login Account Name:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("L" & rCount) = Trim(vItem(1))
    End If
    If InStr(1, vText(i), "User:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("M" & rCount) = Trim(vItem(1))
    End If
    If InStr(1, vText(i), "Employee Number:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("H" & rCount) = Trim(vItem(1))
    End If
    If InStr(1, vText(i), "ICOMS SalesRep ID/Tech ID:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("G" & rCount) = Trim(vItem(1))
    End If
    If InStr(1, vText(i), "ICOMS Login:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("N" & rCount) = Trim(vItem(1))
    End If
    If InStr(1, vText(i), "Last Action Effective Date:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("A" & rCount) = Trim(vItem(1))
    End If

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