Outlook body to Excel Document

Status
Not open for further replies.

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
comment out this line - i was thinking it was for the connection outlook opened (silly me, it's not a database :)) , but it's closing the workbook. We want the workbook open so it runs faster.
xlWB.Close 1

and comment out the End if - it goes with these lines.
If bXStarted Then
xlApp.Quit
 

wmiles

Member
Outlook version
Outlook 2007
Email Account
POP3
This is the current code, I'm getting a message with the following. SGNCCIPS.xls is already open, reopening will cause any changes you made to be discarded. do you want to reopen sgnccips.xls Yes / No. This is on a dialogue box.




Also, it only seems to be running on messages selected, I'm guessing this is for testing purposes.




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
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
This line > Sub CopyToExcel(olItem As Outlook.MailItem)
should cause it to only work as a run a script rule.

on the error, I'm sure it's related to these lines - try uncommenting the close line (leave the if... end if commented out) and see if it works. You can try changing it to xlWB.Save and see if the error comes back.
xlWB.Close 1
' If bXStarted Then
' xlApp.Quit

' End If
 

wmiles

Member
Outlook version
Outlook 2007
Email Account
POP3
I tried the XlWB.Save and that caused the same error.

It still only seems to process the message you are highlighting.
 

wmiles

Member
Outlook version
Outlook 2007
Email Account
POP3
Sorry got that wrong, it processes all items, but only does the catagories colour on the selected item.

It processed as follows.

P130600522 100329 ACTI099 201 199.5

P130600522 100329 ACTI099 201 199.5

P130600522 100329 ACTI099 201 199.5

P130600522 100329 ACTI099 201 199.5

P130600522 100329 ACTI099 201 199.5

P130600522 100329 ACTI099 201 199.5

So it picks up the first file.
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
So its still not clearing the values on multiple messages? We can try switching to EntryIDs and using newmailex from http://www.outlookcode.com/article.aspx?id=62

on the close/save stuff - it looks like the code as written needs to use the close statement. When i get a chance I'll look at changing the code so it keeps it open - but it may still not be fast enough to process a large number of messages at once.
 

wmiles

Member
Outlook version
Outlook 2007
Email Account
POP3
Hi Diane

It basically just repeated the first value, it did repeat it the same amount of times as emails that had been processed.

I'm happy for any help so whenever you get a chance to change the code i'm happy. Its not mega urgent and if you feel its too much work just say.

Regards

Wayne
 

Parick

New Member
Outlook version
Outlook 2007
Email Account
Exchange Server
Hi Diane

It basically just repeated the first value, it did repeat it the same amount of times as emails that had been processed.

I'm happy for any help so whenever you get a chance to change the code i'm happy. Its not mega urgent and if you feel its too much work just say.

Regards

Wayne
Hi Diane, I am having the same issue where it won't process multiple emails arriving quickly. If I forward to myself (with the appropriate rule) and wait as each one is received then the script works. If you can help with the solution you mention above that would be great! But, you do mention it still might not work. What about a rule where I forward it but it delays each forward 10 seconds to allow the script to process?
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Well, it could either be one of the limitations of run a script rules or a factor in how slow it is. It's definitely faster to not close the workbook and reopen it.

You can try converting it to an item add macro, but will need to either use a rule to move the messages to another folder and watch that folder or you'll have to set up an if statement in the macro.
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Hi Diane

It basically just repeated the first value, it did repeat it the same amount of times as emails that had been processed.

I'm happy for any help so whenever you get a chance to change the code i'm happy. Its not mega urgent and if you feel its too much work just say.

Regards

Wayne
If you need to pick up multiple values from a message, you need to move the code that writes to the sheet inside the For... next statement
Code:
  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))

   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
Next
     End If
 

Dominik Leko

New Member
Outlook version
Outlook 2010 64 bit
Email Account
Exchange Server
Dear Diane,

first of all thanks a ton for all the valuable advice! You don't know how much time you saved me and my colleagues at work :)

Now, there is one thing that I cannot get right, so here's my case study:
a) Every day I get 50-100 e-mails from an automated form, with the following elements in the body:

Kontakt osoba jozukić p25
Dodatni tekst mislim da bi bilo dobro da imamo barem jedan komad na nivou firme,štop prekidač,meni konkretno treba za antaru,ali vidim da ide i na druga vozila
Broj proizvoda 700424
Šifra dobavljačevog artikla 700424-VAL
Korisnik :
ciakp25

so, my goal is to extract the information from every single field into an excel sheet, everything in its column. The potential issue is the last one where it's not in the same line, but the pattern recognition is "Korisnik :", and the result is in another line.

So far I've been combining (unsuccessfully) these two threads:
Use a macro to copy data in Outlook email to Excel workbook
Use RegEx to extract text from an Outlook email message

But when I enter and edit everything in the project (both in object and add the module - and my excel sheet is opened in Documents under Korisnik.xlsx), it doesn't work.

The e-mails always have the same sender (noreply@carparts-cat.com) and the same receiver (nabava@ciak-auto.hr), out of which I already created a rule to move it to a specified folder. Of course, if I use the run rule as script I need to make it the only rule, so this one that I mentioned cannot co-exist with "run rule as script". Or could it?
Additional level of complexity might be that I'm already getting orders everyday from noreply@carparts-cat.com, but that's related to another email account (narudzbe@ciak-auto.hr). Also, this e-mail nabava@ciak-auto.hr which I'm receiving is an e-mail group on MS Exchange.

All in all, if the first step can be done (extract the patterns to Excel), I don't mind the clutter in my Inbox. Even if I cannot transfer this "Korisnik :", it's not an issue.

If you find time in the next week or so, I would really appreciate your help.
It's office 2010, and MS Ex account (dominik.leko@ciak-auto.hr).

Thanks, best regards,
Dominik
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
so, my goal is to extract the information from every single field into an excel sheet, everything in its column. The potential issue is the last one where it's not in the same line, but the pattern recognition is "Korisnik :", and the result is in another line.
So Korisnik : is in the message twice and the regex gets the wrong one? Try setting .global. True will return the last one, False = first one. If it's in the middle and the pattern is like this, on two lines (and any others are on one line) , try adding \r or \n to the pattern where the line break is.
Korisnik :
ciakp25


With Reg1
.Pattern =
.Global = True
End With

Is this the only issue or is the script just not working at all?
 

Dominik Leko

New Member
Outlook version
Outlook 2010 64 bit
Email Account
Exchange Server
The script is just not working.
Korisnik : is appearing only once so it's not a proble (maybe I wasn't too clear on this).
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
ok... so it's just that it is on two lines. try a pattern like Korisnik :\s\n(.*)

This pattern worked on the email version of message #31 above -
Code:
    With Reg1
        .Pattern = "(Korisnik :\s*\n(\w*))"
        .Global = True
    End With
Not knowing exactly how the end of the line is formatted (extra spaces etc), it might need a little tweaking.
 

Dominik Leko

New Member
Outlook version
Outlook 2010 64 bit
Email Account
Exchange Server
Hi Diane,

thanks, it will be a bit of tweaking probably but it will be fine I think.
What do you say about the other parts of the post - should I dismiss all the rules except run rule as script?

In general, I'm not sure I did everything right since it's not working - do you have an idea how exactly should the whole script look like, based on what I've written and two of your excellent posts which I linked?

Thanks a lot again,

BR
Dominik
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
If the patterns aren't correct, work with the macros on this page - Use RegEx to extract text from an Outlook email message - select a message and run the macro. Debug.print to see the results of the pattern. After you get the patterns correct, then work on sending the data to excel. This will make debugging it much easier.

You should use case statements with the patterns - you'll need to use more than 3...

Code:
Sub GetValueUsingRegEx()
  Dim olMail As Outlook.MailItem
  Dim Reg1 As RegExp
  Dim M1 As MatchCollection
  Dim M As Match
  Dim var 'As String
  Set olMail = Application.ActiveExplorer().Selection(1)
  Set Reg1 = New RegExp

For i = 1 To 3

With Reg1
  Select Case i
  Case 1
  .Pattern = "(Kontakt osoba(.*)\s*\r)"
  .Global = False
  Case 2

  .Pattern = "(artikla \s*(.*)\r)"
  .Global = False
  Case 3
  .Pattern = "(Korisnik :\s*\n(\w*))"
  .Global = False
  End Select
End With

  If Reg1.Test(olMail.Body) Then

  Set M1 = Reg1.Execute(olMail.Body)
  For Each M In M1
  var = M.SubMatches(1)
  Debug.Print var & " " & i
  If i = 1 Then vtext = var
  If i = 2 Then vtext1 = var
  If i = 3 Then vtext2 = var

  Next
  End If

Next i


Debug.Print "1 " & vText & " 2 " & vText1 & " 3 " & vText2

Set Reg1 = Nothing
End Sub
After it's working, then turn it into a run a script rule.
 
Status
Not open for further replies.
Top