mail outlook to excel

[shailu178]

Dear All,

I need help desparately.

I am reciveing email from one of the job sites and my job is to pull out email address from the body of message .
Doing this manually kills.

Below is the sample of email I recieve.

Job details
Job title: Administrative Assistant - Culinary
Recruiter: XXXXXXXX

Title:Mr
First Name: shelendra
Last Name:singh
Email:XXXXX@XXXX.com

i want to parse the feild Job title & email to an excel sheet.
I tried to modify the code written for Extracting invalid email add (found from this forum)

With my limited knowledge i dont think ill ever be able to write any such code.

need help please​

 

[Derek Brown]

Hello and welcome to The Board.
In order to get information from the body of an email, you need to save it as a text file and then open and read it.

You could try modifying the code at reply #2 at:
http://www.mrexcel.com/forum/showthread.php?t=345240
changing the line "If InStr(1, strText, strDelimiter) > 0 Then" to look for "Email:" (in your example).

You did not say which version of Excel is being used, but it should work for Excel 2003 onwards on Windows.

 

[shailu178]

Hi

Thanks for replying

I tried the code but wasn't able to get the results what i am looking for.

I m using office 2007 on windows

I wanted to extract only two fields form the message of the email . which is Job Title & Email from the body below

Job details
Job title: Administrative Assistant - Culinary
Recruiter: XXXXXXXX

Title:Mr
First Name: shelendra
Last Name:singh
Email:XXXXX@XXXX.com

*****************

i will be grateful if you can help

 

[Derek Brown]

The code in the example requires modification, as indicated in my reply.
Can you post the code changes that you made, please.

 

[shailu178]

Hi Derek

Here is the code i am using currently to extract email id from the body of the message. The code runs form Outlook . Please if you can help me to modify this code to extract Job title as well .

Sub Extract_Invalid_To_Excel()


Dim olApp As Outlook.Application

Dim olExp As Outlook.Explorer

Dim olFolder As Outlook.MAPIFolder

Dim obj As Object

Dim stremBody As String
Dim stremBody1 As String

Dim stremSubject As String

Dim i As Long

Dim x As Long

Dim count As Long

Dim RegEx As Object

' for job title

Dim RegEx1 As Object

Set RegEx1 = CreateObject("VBScript.RegExp")

Set RegEx = CreateObject("VBScript.RegExp")

Dim XLApp As Object 'Excel.Application

Dim xlwkbk As Object 'Excel.Workbook

Dim xlwksht As Object 'Excel.Worksheet

Dim xlRng As Object 'Excel.Range


Set olApp = Outlook.Application

Set olExp = olApp.ActiveExplorer


Set olFolder = olExp.CurrentFolder


'Open Excel

Set XLApp = GetExcelApp

XLApp.Visible = True

If XLApp Is Nothing Then GoTo ExitProc


Set xlwkbk = XLApp.Workbooks.Add

Set xlwksht = xlwkbk.Sheets(1)

Set xlRng = xlwksht.Range("A1")

Dim xlRng1 As Object ' Excel Range

Set xlRng1 = xlwksht.Range("B1")

xlRng1.Value = "Job Title"

xlRng.Value = "Bounced email addresses"


'Set count of email objects

count = olFolder.Items.count


'counter for excel sheet

i = 0
Dim j As Long
j = 0

'counter for emails

x = 1


For Each obj In olFolder.Items

XLApp.StatusBar = x & " of " & count & " emails completed"

stremBody = obj.Body

stremBody1 = obj.Body


stremSubject = obj.Subject


'Check for keywords in email before extracting address


If checkEmail(stremBody) = True Then

'MsgBox ("finding email: " & stremBody)

RegEx.Pattern = "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"
RegEx.IgnoreCase = True

RegEx.MultiLine = False


' If checkEmail(stremBody1) = True Then


RegEx1.Pattern = "\s"
RegEx1.IgnoreCase = True
RegEx1.MultiLine = False




Set olMatches = RegEx.Execute(stremBody)



For Each Match In olMatches

xlwksht.Cells(i + 2, 1).Value = Match

i = i + 1


xlwksht.Cells(j + 2, 1).Value = Match

j = j + 1



Next Match

'TODO move or mark the email that had the address extracted

Else

'To view the items that aren't being parsed uncomment the following line

'MsgBox (stremBody)

End If


x = x + 1

Next obj

XLApp.ScreenUpdating = True

MsgBox ("Invalid Email addresses are done being extracted")


ExitProc:

Set xlRng = Nothing

Set xlRng1 = Nothing

Set xlwksht = Nothing

Set xlwkbk = Nothing

Set XLApp = Nothing

Set emItm = Nothing

Set olFolder = Nothing

Set olNS = Nothing

Set olApp = Nothing

End Sub


Function GetExcelApp() As Object

' always create new instance

On Error Resume Next

Set GetExcelApp = CreateObject("Excel.Application")

On Error GoTo 0

End Function


Function checkEmail(ByVal Body As String) As Boolean

Dim keywords(25) As String

keywords(0) = "Delivery to the following recipients failed"

keywords(1) = "user unknown"

keywords(2) = "The e-mail account does not exist"

keywords(3) = "undeliverable address"

keywords(4) = "550 Host unknown"

keywords(5) = "No such user"

keywords(6) = "Addressee unknown"

keywords(7) = "Mailaddress is administratively disabled"

keywords(8) = "unknown or invalid"

keywords(9) = "Recipient address rejected"

keywords(10) = "disabled or discontinued"

keywords(11) = "Recipient verification failed"

keywords(12) = "no mailbox here by that name"

keywords(13) = "This user doesn't have a yahoo.com account"

keywords(14) = "No mailbox found"

keywords(15) = "not our customer"

keywords(16) = "mailbox unavailable"

keywords(17) = "Mailbox disabled"

keywords(18) = "mailbox is inactive"

keywords(19) = "address error"

keywords(20) = "unknown recipient"

keywords(21) = "Job title:"

keywords(22) = "CV"

keywords(23) = "Position"

keywords(24) = "Application"





'Default value

checkEmail = False

For Each word In keywords

If InStr(1, Body, word, vbTextCompare) > 1 Then

checkEmail = True

Exit For

End If

Next word

End Function




Thank you in advance