Outlook body to Excel Document

Status
Not open for further replies.

wmiles

Member
Outlook version
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
 
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.
 
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.
 
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
 
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
 
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
 
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*))"
 
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
 
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.
 
what did the error say?

I think you are missing a leading (

s*([\d-\.]*))"
 
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
 
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.
 
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.
 
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.
 
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.)
 
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
 
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
 
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.
 
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
kburrows Outlook Email Body Text Disappears/Overlaps, Folders Switch Around when You Hover, Excel Opens Randomly and Runs in the Background - Profile Corrupt? Using Outlook 0
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
G Retaining Tabs in outlook body Using Outlook 2
S Create Outlook Task from Template and append Body with Email Body Outlook VBA and Custom Forms 4
S New Outlook Appointment - Select All Body Text and Change Font and Size Outlook VBA and Custom Forms 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
A Outlook can't remember outlook.com, Exchange password. Using Outlook 0
S Related messages show in main Outlook window vice new Advanced Find windows Using Outlook 1
H Force Outlook 2019 with GMail 2-Step to Require Login? Using Outlook 0
V Setting up Outlook 2021 on new computer Using Outlook 2
G Add Map It button to Custom Contacts Form in Outlook Outlook VBA and Custom Forms 1
X Custom icon (not from Office 365) for a macro in Outlook Outlook VBA and Custom Forms 1
Victor_50 Problem - Google Workspace will stop "unsafe" access to Outlook end 2024 Using Outlook 3
C New pc, new outlook, is it possible to import auto-complete emailaddress Using Outlook 4
T Outlook 365 won't take new working password Using Outlook 0
P Can't add custom field to custom Outlook form, it always adds to the Folder instead Outlook VBA and Custom Forms 2
B Sync Outlook Public Folders to Contacts Using Outlook 2
D Delete Outlook emails from MS server Using Outlook 12
B Outlook tasks and PDF Using Outlook 4
D Outlook 2019 is no longer asking for password ... Using Outlook 5
Kika Melo How to mark as Junk any message not from Contacts (in Outlook.com) Using Outlook 3

Similar threads

Back
Top