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