I'm Still trying to Extract Email Body to Excel

[bclor3591]

I hate to keep posting the same stuff over and over, but I need someone that has done VBA coding that can look at some VBA code that I got from this website to see what I'm doing wrong trying to extract 5 pieces of information from each Email Body to a separate column in a spreadsheet in either a CSV formamted file or Excel? The deadline for this project has come a nd gone and now I'm cut/pasting 400-500 emails a day into a spreadsheet. This is very time consuming, and prone to human error! Please let me know and I can send you a email sample and the VBA code that I'm trying to get working.
Thank you,
Bob Loring

 

[Kyle123]

Why don't you post your code?

 

[bclor3591]

OK, Here Goes...

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub DumpMail()
Dim myOlApp As Outlook.Application
Dim mpfInbox As Outlook.MAPIFolder
Dim obj As Outlook.MailItem
Dim i As Integer
Dim X As Integer
Dim Z As Integer
Dim Y As Integer
Dim BodyArray As Variant
Set myOlApp = CreateObject("Outlook.Application")
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
Set mpfInbox = myFolder.Folders("SERVICE_CHECK_EMAILS") 'Edit this
For i = 1 To mpfInbox.Items.Count
If mpfInbox.Items(i).Class = olMail Then
Set obj = mpfInbox.Items.Item(i)
If obj.UnRead Then
BodyArray = Split(obj.Body, vbLf)
For X = LBound(BodyArray) To UBound(BodyArray)
If Left(BodyArray(X), 9) = "REPORT #:" Then ReportNo = Replace(BodyArray(X), Chr(13), "")
If Left(BodyArray(X), 9) = "REPORTED:" Then ReportDate = Replace(BodyArray(X), Chr(13), "")
If Left(BodyArray(X), 9) = "Guest Information:" Then
For Z = X + 1 To UBound(BodyArray)
GuestInfo = GuestInfo & " " & Replace(BodyArray(Z), Chr(13), "")
Next
Exit For
End If
If Left(BodyArray(X), 22) = "Restaurant Information" Then StoreInfo = Replace(BodyArray(X), Chr(13), "")
If Replace(BodyArray(X), Chr(13), "") = "ADDITIONAL COMMENTS" Then
For Y = X + 1 To UBound(BodyArray)
Comments = Comments & " " & Replace(BodyArray(Y), Chr(13), "")
Next
Exit For
End If
Next
'This logic builds the CSV File
CSVString = ReportNo & ", " & ReportDate & ", " & GuestInfo & ", " & StoreInfo & ", " & Comments
MyFile = "C:\Users\bloring\My Documents\ServiceCheck\SC_EXTRACTOR.csv" 'Edit this
fnum = FreeFile()
Open MyFile For Output As fnum
Print #fnum, CSVString
Close #fnum
obj.UnRead = False
Sleep (1000)
CSVString = ""
ReportNo = ""
ReportDate = ""
StoreInfo = ""
Comments = ""
End If
End If
Next
End Sub

If you need a sample of the Email, I will have to email those to you?

 

[Kyle123]

Can you put that in Code tags please? It makes my eyes bleed

 

[bclor3591]

Hello Kyle,

I'm not sure what you mean by Code Tags? Do you mean add Comments to the code lines?

 

[Kyle123]

No I mean wrap your code in [ code ]your code[ / code ] but remove the spaces.

It looks like this:

sdfsdfsdfsdf

and makes it much easier to read

You also haven't said which bit isn't working.

 

[bclor3591]

Hi Kyle,

I s this what you meant?

[ code ]Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub DumpMail()
Dim myOlApp As Outlook.Application
Dim mpfInbox As Outlook.MAPIFolder
Dim obj As Outlook.MailItem
Dim i As Integer
Dim X As Integer
Dim Z As Integer
Dim Y As Integer
Dim BodyArray As Variant
Set myOlApp = CreateObject("Outlook.Application")
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
Set mpfInbox = myFolder.Folders("SERVICE_CHECK_EMAILS") 'Edit this
For i = 1 To mpfInbox.Items.Count
If mpfInbox.Items(i).Class = olMail Then
Set obj = mpfInbox.Items.Item(i)
If obj.UnRead Then
BodyArray = Split(obj.Body, vbLf)
For X = LBound(BodyArray) To UBound(BodyArray)
If Left(BodyArray(X), 9) = "REPORT #:" Then ReportNo = Replace(BodyArray(X), Chr(13), "")
If Left(BodyArray(X), 9) = "REPORTED:" Then ReportDate = Replace(BodyArray(X), Chr(13), "")
If Left(BodyArray(X), 9) = "Guest Information:" Then
For Z = X + 1 To UBound(BodyArray)
GuestInfo = GuestInfo & " " & Replace(BodyArray(Z), Chr(13), "")
Next
Exit For
End If
If Left(BodyArray(X), 22) = "Restaurant Information" Then StoreInfo = Replace(BodyArray(X), Chr(13), "")
If Replace(BodyArray(X), Chr(13), "") = "ADDITIONAL COMMENTS" Then
For Y = X + 1 To UBound(BodyArray)
Comments = Comments & " " & Replace(BodyArray(Y), Chr(13), "")
Next
Exit For
End If
Next
'This logic builds the CSV File
CSVString = ReportNo & ", " & ReportDate & ", " & GuestInfo & ", " & StoreInfo & ", " & Comments
MyFile = "C:\Users\bloring\My Documents\ServiceCheck\SC_EXTRACTOR.csv" 'Edit this
fnum = FreeFile()
Open MyFile For Output As fnum
Print #fnum, CSVString
Close #fnum
obj.UnRead = False
Sleep (1000)
CSVString = ""
ReportNo = ""
ReportDate = ""
StoreInfo = ""
Comments = ""
End If
End If
Next
End Sub[ /code ]

None of the information is getting to the CSV file.

 

[S.H.A.D.O.]

Nearly, do the same again but remove the spaces inside the [] brackets.
I hope this helps!

 

[bclor3591]

I forgot to remove the spaces, sorry. How about this?

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub DumpMail()
Dim myOlApp As Outlook.Application
Dim mpfInbox As Outlook.MAPIFolder
Dim obj As Outlook.MailItem
Dim i As Integer
Dim X As Integer
Dim Z As Integer
Dim Y As Integer
Dim BodyArray As Variant
Set myOlApp = CreateObject("Outlook.Application")
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
Set mpfInbox = myFolder.Folders("SERVICE_CHECK_EMAILS") 'Edit this
For i = 1 To mpfInbox.Items.Count
    If mpfInbox.Items(i).Class = olMail Then
        Set obj = mpfInbox.Items.Item(i)
            If obj.UnRead Then
                  BodyArray = Split(obj.Body, vbLf)
                For X = LBound(BodyArray) To UBound(BodyArray)
                    If Left(BodyArray(X), 9) = "REPORT #:" Then ReportNo = Replace(BodyArray(X), Chr(13), "")
                    If Left(BodyArray(X), 9) = "REPORTED:" Then ReportDate = Replace(BodyArray(X), Chr(13), "")
                    If Left(BodyArray(X), 9) = "Guest Information:" Then
                    For Z = X + 1 To UBound(BodyArray)
                    GuestInfo = GuestInfo & " " & Replace(BodyArray(Z), Chr(13), "")
                    Next
                    Exit For
                    End If
                    If Left(BodyArray(X), 22) = "Restaurant Information" Then StoreInfo = Replace(BodyArray(X), Chr(13), "")
                    If Replace(BodyArray(X), Chr(13), "") = "ADDITIONAL COMMENTS" Then
                       For Y = X + 1 To UBound(BodyArray)
                       Comments = Comments & " " & Replace(BodyArray(Y), Chr(13), "")
                       Next
                       Exit For
                    End If
                Next
   'This logic builds the CSV File
   CSVString = ReportNo & ", " & ReportDate & ", " & GuestInfo & ", " & StoreInfo & ", " & Comments
                MyFile = "C:\Users\bloring\My Documents\ServiceCheck\SC_EXTRACTOR.csv" 'Edit this
                fnum = FreeFile()
                Open MyFile For Output As fnum
                Print #fnum, CSVString
                Close #fnum
                obj.UnRead = False
                Sleep (1000)
                CSVString = ""
                ReportNo = ""
                ReportDate = ""
                StoreInfo = ""
                Comments = ""
            End If
    End If
Next
End Sub

None of the information is getting to the CSV file.

 

[bclor3591]

Here is a SMAPLE of the EMAILS that I get: I HIGHLIGHTED the information that I need to capture. Any help anyone can give me on this would be greatly appreciated!
________________________________________
From: ServiceCheck@servicecheck.net
Sent: Wednesday, December 05, 2012 3:34:11 PM (UTC-05:00) Eastern Time (US & Canada)
To: Smith, John
Subject: Restaurant 0145 - PROBLEM Report 8009355 - Guest ANN SUMMERS
Company Name Here
Guest Relations - Web Entry
INCIDENT REPORT
ALERT
------
* Contact Requested

REPORT #: 8009355
--------------------
REPORTED: Wednesday, Dec 05, 2012 03:25 PM EST
----------------------------------------------------
ATTENTION:
----------
Bob Loring
IMPORTANT INSTRUCTIONS:
--------- ------------
The Company standard is to respond back to the guest within 24-48 hours and close the report
within 3 days.
Guest Information:
--------------------------
ANN SUMMERS
13 Any St.
Anywhere, Massachusetts 01749
Daytime Phone: (123) 456-7890
Evening Phone: Not Provided
Email: annsummers@yahoo.com
CONTACT HISTORY:
*Complaints = Emergency + Problem Reports Prior Contacts Prior Complaints*
---------------------------------------------------- -------------- -----------------
Company Name: None None
Other ServiceCheck clients: None None
Restaurant Information
----------------------------------------------------
0145 - HUDSON - DINE IN

REPORT DETAILS:
---------------
Occurred: Wednesday, Dec 05, 2012 02:00 PM
----------------------------------------------------

Problem - Marketing - Website/Online Issues

ADDITIONAL COMMENTS:
--------------------
*** Report details were entered by Guest *** We usually order online from our iPad. On December 2nd we tried and your site no longer works with our iPad Safari or Chrome browser.
All of the order screens are pop ups that do not load. We found this inconvenient. We ended up calling but the city listed for our Company Name Here is wrong in your local ads which was confusing, and the person who answered at your restaurant was not particularly friendly about the my asking about the wrong city being listed in the ad. He seemed annoyed with my asking if I was calling the correct location. Anyway with all the confusion the food was very good but we forgot to provide our rewards card. Since I saved the receipt is there a way we could have our rewards points added to our account? What information do you need if
this is possible? Also maybe the address of our local store and the website could be
fixed? Our store is listed as 12 Narragansett Park Narragansett RI 02916 However it is
actually located in East Providence RI Thanks, Matt Girouard