Outlook body to Excel Document

Status
Not open for further replies.

wmiles

Member
Outlook version
Outlook 2007
Email Account
POP3
Hi All, I'm new to the forum and I have a question that I'm hoping you can help me with. All help is appreciated. I'm trying to use the following code to export data from Outlook to Excel. What I would like to know is that whether I can just choose part of the email body by line number rather than via the split. The line on my Emails received would be space separated for Example P130600439 100356 ACTI149 202 0
Code:
Option Explicit
Sub CopyToExcel(olItem As Outlook.MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
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:\test\test.xls"        'the path of the workbook
    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("Test")
    'Process the message record
    sText = olItem.Body
    vText = Split(sText, Chr(13))
    'Find the next empty line of the worksheet
    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
    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), "Vendor:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("B" & rCount) = Trim(vItem(1))
        End If
        If InStr(1, vText(i), "Event Type:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("C" & rCount) = Trim(vItem(1))
        End If
        If InStr(1, vText(i), "Services Affected:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("D" & rCount) = Trim(vItem(1))
        End If
        If InStr(1, vText(i), "Location:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("E" & rCount) = Trim(vItem(1))
        End If
        If InStr(1, vText(i), "Current Status:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("F" & rCount) = Trim(vItem(1))
        End If
        If InStr(1, vText(i), "Event Start Time:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("G" & rCount) = Trim(vItem(1))
        End If
        If InStr(1, vText(i), "Event Stop Time:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("H" & rCount) = Trim(vItem(1))
        End If
        If InStr(1, vText(i), "Ticket:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("I" & rCount) = Trim(vItem(1))
        End If
    Next i
    xlWB.Close 1
    If bXStarted Then
        xlApp.Quit
    End If
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
End Sub
 

wmiles

Member
Outlook version
Outlook 2007
Email Account
POP3
Hi Diane, basically say I had an email which contained the following text amongst other text I would need to pick out the relevant data. I would like to get the script to find the line with P130600439 100356 ACTI149 202 0 on it and split them into columns adding to the last row each time in excel. The line will always start with P130 if this helps as below. The data I've entered in the above post is just an example of someone elses work which I'm trying to adapt. I'm using Run a script rule to activate the script in the current message. See example of email I receive. Also, I have no idea about these things so I'm working under instruction.

Example email.

List of APPROVED tracksheets by Commercial Assistant For reference the following tracksheets have been actioned on the below date

Vendor: None Contract: None Todays Date: 19-JUN-13

PO NUMBER TM ID TRACKSHEET REF LINE ID NET LINE VALUE COMMENTS

P130600439 100356 ACTI149 202 0 <<<------ This is the only relevant information to be moved to the excel spread sheet.
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Ok, so you aren't using the vendor etc lines.

If the message contains just one line, you can use left to pick up the line then get the length and copy it. Regex would work too. You still need to split the text into cells - you can't insert using text to columns. (or at least I don't know how.)

if the email has multiple lines, walking it with your original code would be easier, although it would need to be changed to work.

Code:
Option Explicit
Sub CopyToExcel()
Dim olItem As Outlook.MailItem
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText, vText2, vText3, vText4, vText5 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\username\Documents\test.xlsx"        'the path of the workbook
    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("Test")
   ' Process the message record
   Set olItem = Application.ActiveExplorer().Selection(1)
 
   'Find the next empty line of the worksheet
    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
    rCount = rCount + 1
  
  
    sText = olItem.Body
  
  
   Dim Reg1 As RegExp
   Dim M1 As MatchCollection
   Dim M As Match
      
  ' Debug.Print olMail.Body
  
   Set Reg1 = New RegExp
  
   ' \s* = invisible spaces
   ' \d* = match digits
   ' \w* = match alphanumeric
  
   With Reg1 
 
'we could use d instead of w- if last value is more than 1 digit, use \d*
       .Pattern = "((P130\w*)\s*(\w*)\s*(\w*)\s*(\w*)\s*(\d))"
       '.Global = True
   End With
   If Reg1.test(sText) Then
  
       Set M1 = Reg1.Execute(sText)
       For Each M In M1
          vText = Trim(M.SubMatches(1))
          vText2 = Trim(M.SubMatches(2))
          vText3 = Trim(M.SubMatches(3))
          vText4 = Trim(M.SubMatches(4))
          vText5 = Trim(M.SubMatches(5))
       Next
   End If
 xlSheet.Range("B" & rCount) = vText
 xlSheet.Range("c" & rCount) = vText2
 xlSheet.Range("d" & rCount) = vText3
 xlSheet.Range("e" & rCount) = vText4
 xlSheet.Range("f" & rCount) = vText5
    xlWB.Close 1
    If bXStarted Then
        xlApp.Quit
    End If
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
End Sub

- - - Updated - - -

Oh, see Using regex in outlook for more information - you will need to reference the regex engine.
 

wmiles

Member
Outlook version
Outlook 2007
Email Account
POP3
Hi Diane




Appreciate your help so far.




The data required is not the only line in the email, it's always received as below. I'm not even fussed about when it gets to Excel that it splits it into columns, the whole line starting with P130 can go into one column on one row.




Example email.



List of APPROVED tracksheets by Commercial Assistant For reference the following tracksheets have been actioned on the below date
Vendor: None Contract: None Todays Date: 19-JUN-13



PO NUMBER TM ID TRACKSHEET REF LINE ID NET LINE VALUE COMMENTS



P130600439 100356 ACTI149 202 0
 

wmiles

Member
Outlook version
Outlook 2007
Email Account
POP3
Hi Diane

It works brilliant it imports perfectly into columns, but, it only works if its the only line in the email. unfortunately as per my example below, its not the only text in the body.

Example email.
List of APPROVED tracksheets by Commercial Assistant For reference the following tracksheets have been actioned on the below date
Vendor: None Contract: None Todays Date: 19-JUN-13
PO NUMBER TM ID TRACKSHEET REF LINE ID NET LINE VALUE COMMENTS
P130600439 100356 ACTI149 202 0
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
But do you need all 3 lines or just the P130 line? My code sample does just the P130 line. Grabbing the other 2 is as simple as adding another pattern and set of m statements (basically, the code block that gets the data and dumps it in the cell, below).

BTW, my code is 'select message and run' to test. Your original code ran as a rules script. It can be converted back by changing
Sub CopyToExcel()
Dim olItem As Outlook.MailItem

to
Sub CopyToExcel(olItem As Outlook.MailItem)

it's just easier to test on the same message over and over this way.

to dump everything into one cell you'd change the section of code that gets the text to this:
With Reg1
.Pattern = "((P130\w*\s*\w*\s*\w*\s*\w*\s*\d))"
End With
If Reg1.test(sText) Then

Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))
Next
End If
xlSheet.Range("B" & rCount) = vText
xlWB.Close 1
 

wmiles

Member
Outlook version
Outlook 2007
Email Account
POP3
Wow Diane we are almost there, I have I think one last question, as these are prices they go to 2 decimal places for instance 41.06.




I change the code to use d* but its only showing as 41 not 41.06, Any ideas how to fix that.




'we could use d instead of w- if last value is more than 1 digit, use \d*
.Pattern = "((P130\w*)\s*(\w*)\s*(\w*)\s*(\w*)\s*(\d*))"
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Try using

[\d-\.]* in place of the \d

This pattern will also work if you are dumping everything in one cell:

> Pattern = "((P130[\w-\s]*[\d-\.]*))"

This shorter version wraps lines though:

> Pattern = "((P130[\w-\s-\.]*))"

the brackets [] say "match anything inside" and the * says any number of times, so it will match

P130600439 100356 ACTI149 202 12.34

P130600439 100356 ACTI149 202 12.3456

P1306 00439 100 356 ACTI1 49 202 12.3456

but not

P130600439 100356 ACTI149 202 1,2345.87
 

wmiles

Member
Outlook version
Outlook 2007
Email Account
POP3
Hi Diane




Not sure if I went wrong somewhere.




I tried




> Pattern = "((P130\w*)\s*(\w*)\s*(\w*)\s*(\w*)\s*[\d-\.]*))"




and




> Pattern = "((P130\w*)\s*(\w*)\s*(\w*)\s*(\w*)\s*(\d-\.)*))"






Both produced errors.
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
what did the error say?

I think you are missing a leading (

s*([\d-\.]*))"
 

wmiles

Member
Outlook version
Outlook 2007
Email Account
POP3
Superb, all working now, I've got to move it into a working environment tomorrow.

Thank you for all your help today, I'm sorry if I've taken up too much of your time. I really appreciate everything you have done. In the long run the script will save me so much time not having to go through around 400 - 600 emails per week.

Thanks Again

Wayne
 

wmiles

Member
Outlook version
Outlook 2007
Email Account
POP3
Hi Diane

Sorry to bother you again, I've run into a little issue, it all works perfectly if only one email is received at a time, the problem I have is that if it receives maybe 10 - 20 emails at the same time it seems to copy the same line several times, its like it cant cope with it so pulls the same data.

I'm not sure if this is a problem with the script or that the rule i'm running needs to have some delay put on it between receiving each mail.
 

wmiles

Member
Outlook version
Outlook 2007
Email Account
POP3
Its definitely an issue with the rule to run a script, they seem to run at the same time, I thought that outlook processed message one by one but it doesn't seem to. it causes confusion for the script. Does anyone know if its possible to run a rule message by message and possibly put a delay of say 10 seconds between each message.
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
It does run one at a time, but very, very fast. It may be too many at a time for it to handle (rules are bad with high volume - see processing mail for more information) or it could be that we need to clear vText or some other value from memory before the next message is processed. There is also the option of automating just the processing - you select a batch of messages and run the macro so it steps through each message.

Try adding vText = "" (and all the others) at the top, before set olitem line. I'd probably set stext to = "" too.

I'd add olitem.categories = "processed" and olitem.save at the end to see if it is skipping any.

If that does not work, we can try converting it to newmailex and if volume is still too high, have it run on a selection of messages.

One thing - on your rule, are you processing every message (no conditions) or do you have the rule checking for a matching subject or something so messages not matching are tossed before the script? And do not do any other actions in the rule - check for conditions then hand it off to the script. Let the script do all actions

It might be faster to set the workbook path outside of the macro too, but I'm not sure if it will help enough.

As an FYI, based on that volume, I think the script is overwhelmed.
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
oh and I think I'd remove this line -
If bXStarted Then
xlApp.Quit

so the workbook is not closed each time. That will speed it up a lot.

And make sure
Set Reg1 = Nothing

is in with the other objects do its cleared. If it's not in your code, just setting that might be enough to clear the values, without using vtext = "" at the top.

(But I still think it's a volume thing.)
 

wmiles

Member
Outlook version
Outlook 2007
Email Account
POP3
Hi Diane




Thanks for all your information




This is the current code, I'm not sure where to add / remove the bits you have suggested. I'm a bit clueless when it come to these things, I work in an office doing paperwork. That's why I appreciate the help you are giving me.




Code:
Option Explicit
Sub CopyToExcel(olItem As Outlook.MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText, vText2, vText3, vText4, vText5 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:\SGNCCIPS\SGNCCIPS.xls"        'the path of the workbook
    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("Test")
   ' Process the message record
   Set olItem = Application.ActiveExplorer().Selection(1)
   
   'Find the next empty line of the worksheet
    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
    rCount = rCount + 1
    
    
    sText = olItem.Body
    
    
   Dim Reg1 As RegExp
   Dim M1 As MatchCollection
   Dim M As Match
        
  ' Debug.Print olMail.Body
    
   Set Reg1 = New RegExp
    
   ' \s* = invisible spaces
   ' \d* = match digits
   ' \w* = match alphanumeric
    
   With Reg1
 
 
'we could use d instead of w- if last value is more than 1 digit, use \d*
       .Pattern = "((P130\w*)\s*(\w*)\s*(\w*)\s*(\w*)\s*([\d-\.]*))"
       '.Global = True
   End With
   If Reg1.Test(sText) Then
    
       Set M1 = Reg1.Execute(sText)
       For Each M In M1
          vText = Trim(M.SubMatches(1))
          vText2 = Trim(M.SubMatches(2))
          vText3 = Trim(M.SubMatches(3))
          vText4 = Trim(M.SubMatches(4))
          vText5 = Trim(M.SubMatches(5))
       Next
   End If
 
 

 xlSheet.Range("B" & rCount) = vText
 xlSheet.Range("c" & rCount) = vText2
 xlSheet.Range("d" & rCount) = vText3
 xlSheet.Range("e" & rCount) = vText4
 xlSheet.Range("f" & rCount) = vText5
 
 

    xlWB.Close 1
    If bXStarted Then
        xlApp.Quit
   
    End If
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
End Sub
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Try this - create a category called processed (or use an existing category) and see if they all get touched by the code.

Code:
Option Explicit
Sub CopyToExcel(olItem As Outlook.MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText, vText2, vText3, vText4, vText5 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:\SGNCCIPS\SGNCCIPS.xls"        'the path of the workbook
    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("Test")
   ' Process the message record
   Set olItem = Application.ActiveExplorer().Selection(1)
 
   'Find the next empty line of the worksheet
    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
    rCount = rCount + 1
   
 
' may not be needed 
 
sText = "" 
 
vText = "" 
 
vText2 = "" 
 
vText3 = "" 
 
vText4 = "" 
 
vText5 = ""
    sText = olItem.Body
  
  
   Dim Reg1 As RegExp
   Dim M1 As MatchCollection
   Dim M As Match
      
  ' Debug.Print olMail.Body
  
   Set Reg1 = New RegExp
  
   ' \s* = invisible spaces
   ' \d* = match digits
   ' \w* = match alphanumeric
  
   With Reg1 
 
'we could use d instead of w- if last value is more than 1 digit, use \d*
       .Pattern = "((P130\w*)\s*(\w*)\s*(\w*)\s*(\w*)\s*([\d-\.]*))"
       '.Global = True
   End With
   If Reg1.Test(sText) Then
  
       Set M1 = Reg1.Execute(sText)
       For Each M In M1
          vText = Trim(M.SubMatches(1))
          vText2 = Trim(M.SubMatches(2))
          vText3 = Trim(M.SubMatches(3))
          vText4 = Trim(M.SubMatches(4))
          vText5 = Trim(M.SubMatches(5))
       Next
   End If
 xlSheet.Range("B" & rCount) = vText
 xlSheet.Range("c" & rCount) = vText2
 xlSheet.Range("d" & rCount) = vText3
 xlSheet.Range("e" & rCount) = vText4
 xlSheet.Range("f" & rCount) = vText5
    xlWB.Close 1
 '   If bXStarted Then
  '      xlApp.Quit
 
' could do other things- mark read etc
' we want to see which ones the code touched
  olItem.Categories = "processed"
  olItem.Save
    End If 
 
Set Reg1 = Nothing
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
End Sub
 

wmiles

Member
Outlook version
Outlook 2007
Email Account
POP3
Hi Diane

Not sure if I went wrong somewhere, I clicked on tools, categorize, added a category of processed with a colour. I then run the rule again and nothing happened.

I used the new code as above.
 

wmiles

Member
Outlook version
Outlook 2007
Email Account
POP3
Hi Diane




I've run it again in the inbox and I got the error




Compile Error: End If without block if



End If


Set Reg1 = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
E Copy e-mail body from outlook and insert into excel Outlook VBA and Custom Forms 3
K Importing appointment body from excel in outlook 2010 Using Outlook 1
M White square in body of Outlook Messages (O2016 Version 2012 32bit Click To Run) Using Outlook 4
A How to get body of all emails in outlook 2016 to view in blue color Using Outlook 1
L dynamic and static dates in Outlook contact "notes" ie. body Using Outlook 2
P Insert link in email body to attached document in Outlook 365 Outlook VBA and Custom Forms 0
W Space in an Outlook appointment body Using Outlook 0
J VBA Outlook : Subject line : Cut and Paste name to heading , number to very end of the body of Email Outlook VBA and Custom Forms 1
C Transfer Outlook TextBox Text Into Email Body Outlook VBA and Custom Forms 2
K ind specific Subject line from outlook and copy the content of the email body to exce Outlook VBA and Custom Forms 0
D Outlook macro with today's date in subject and paste clipboard in body Outlook VBA and Custom Forms 1
K Extract email address from body and auto-reply outlook Using Outlook 1
K Display sub-folders in body of outlook Using Outlook 1
divan Outlook 2007 - Replace email body with custom text Using Outlook 9
Vijay Kumar Tables in outlook body Outlook VBA and Custom Forms 1
J Outlook body to word document Outlook VBA and Custom Forms 11
Aussie Looking for Outlook macro to Copy Recipient Names into Email Body Outlook VBA and Custom Forms 3
R Body of email not visible in Outlook Data File Sent Folder Using Outlook 4
H Using Outlook Rules to search for NewLines in message body Using Outlook 1
S Pre populate subject + body + attachment to already open email in outlook 2007 Using Outlook 2
I Outlook Appointments - Setting default text in message body Using Outlook 3
P HTA creating Outlook MeetingItem - need formatted body text Using Outlook 4
M When I click “new message” in outlook, my cursor defaults to the body of the m Using Outlook 6
M Mail in HTML format can't be sent if url or number is in the body Outlook 2010 Using Outlook 2
L No body text in Outlook 2010 messages Using Outlook 0
S Blank body when replying with an Outlook Form. Using Outlook 21
W Recipients of Outlook messages have characters/words missing in body of message Using Outlook 6
S Clickable link on Outlook HTML Body Outlook VBA and Custom Forms 3
T How to get MailItem.Body without security warning in Outlook 2010 Outlook VBA and Custom Forms 2
T Can not change email body content on Outlook 2010 Outlook VBA and Custom Forms 2
S HELP: Create Buttons in Outlook Email body or Tool bar Outlook VBA and Custom Forms 1
e_a_g_l_e_p_i Can someone explain syncing with Outlook and Gmail Using Outlook 0
K Outlook Office 365 VBA download attachment Outlook VBA and Custom Forms 2
e_a_g_l_e_p_i Gmail in Outlook 2010 preview issue Using Outlook 4
I Outlook is stuck at "Updating Calendar" Using Outlook 1
AmonRa Outlook 365 calendar - too much white space Using Outlook 0
e_a_g_l_e_p_i Outlook 2010 Help setting up Gmail account in Outlook 2010 Using Outlook 3
C-S-R How to clear an Outlook (To Do) Task Flag? Using Outlook 8
N How do I make Outlook autocomplete addresses from a list of recognised <full_names> only? Using Outlook 2
P Outlook 2019 UI changes after 20H2 update Using Outlook 1
R How to restrict GWSMO sync to Outlook Send/Receive cycles Using Outlook 0
B Outlook 2016 Unable to view images or logos on the outlook 2016 emails the same html code works well when i use outlook 2010 Using Outlook 0
S Outlook 2007 crash linked to gdiplus.dll Using Outlook 0
P Sending email from outlook IMAP to GMAIL where embedded images are added as attachment Using Outlook 1
M Outlook 2010 How could I globally redesign an outlook template form/region/inspector template used to display mail lists or an individual mails? Outlook VBA and Custom Forms 0
T The Linked Image Cannot Be Displayed in Outlook Using Outlook 5
M Outlook 2010 Outlook 2010 with O365 / Exchange Online Using Outlook 0
S Outlook 2016 Change how Outlook shows me contacts in emails Using Outlook 0
A OutLook For Mac 16.46 Comes Up In Small Window When Opening Using Outlook 4
S Outlook 2007 - Automatic purge fail Using Outlook 0

Similar threads

Top