Outlook body to Excel Document

[wmiles]

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

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

 

[Diane Poremsky]

Well, technically, you are using line # by using i.

Do you want it to select a line and send it to excel, letting excel's text to columns converter break it into cells?

 

[wmiles]

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]

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.

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]

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]

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]

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]

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]

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]

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]

what did the error say?

I think you are missing a leading (

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

 

[wmiles]

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]

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]

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]

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]

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]

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.

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]

Try this - create a category called processed (or use an existing category) and see if they all get touched by the 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]

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]

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