macro to export outlook emails to excel

[Wichiepr]

HI

I am really new in VBA. Excuse me English. I read a lot of article about this, try some but I still don't get it. I need to read this text and extract it to a row in Excel in a different cell each one. I have a formula on cell B-8 to execute some logic. After that I have an app to convert it in cvs, I don't know i can do it from excel since is open. I need to Use the file, close it and replace the file with a new one every time. Path C:\canvas\emails.xlsx

El número de orden de trabajo referenciado es C5937015 Cell B-1
Edificio: Store #12012 Cell B-2
Prioridad: P3 - Alto Cell B-3
País, Estado, Ciudad: PR, PR, Fajardo Cell B-4
Piso: All: 100 CALLE 12
Nombre de contacto: NORAIVETTE GONZALEZ
Teléfono de contacto: (787) 863-1475 Cell 7

Thanks for your help

 

[Diane Poremsky]

This is an outlook macro that uses regex to get values from email and send it to excel.
Use a macro to copy data in Outlook email to Excel workbook

Switching it to an Excel macro won't be too hard - you would remove the excel app parts and reference outlook using a similar method
Dim olApp As Outlook.Application
Dim olItem As Outlook.MailItem
Dim blnCreated As Boolean
Dim olNs As Outlook.Namespace

Set olApp = Outlook.Application
If olApp Is Nothing Then
Set olApp = Outlook.Application
blnCreated = True
Err.Clear
Else
blnCreated = False
End If


See Get two (or more) values from a message (it's the second macro) for regex to get multiple items from a message.

 

[Wichiepr]

This is an outlook macro that uses regex to get values from email and send it to excel.
Use a macro to copy data in Outlook email to Excel workbook

Switching it to an Excel macro won't be too hard - you would remove the excel app parts and reference outlook using a similar method
Dim olApp As Outlook.Application
Dim olItem As Outlook.MailItem
Dim blnCreated As Boolean
Dim olNs As Outlook.Namespace

Set olApp = Outlook.Application
If olApp Is Nothing Then
Set olApp = Outlook.Application
blnCreated = True
Err.Clear
Else
blnCreated = False
End If


See Get two (or more) values from a message (it's the second macro) for regex to get multiple items from a message.

First Thanks for taking your time, I try the Macro and try to add some other other patter like this and I am getting and error on the Select i, I really don't know how to proceed

For i = 1 To 3

Option Explicit
Private Const xlUp As Long = -4162
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 rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim Reg1 As Object
Dim M1 As Object
Dim M As Object

enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Canvas\emails.xlsx"
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("Data")
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1

sText = olItem.Body
Set Reg1 = CreateObject("VBScript.RegExp")
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric

For i = 1 To 3
With Reg1
Select Case i
Case 1
.Pattern = "(Order ID\s[:]([\w-\s]*)\s*)\n"
.Global = False

Case 2
.Pattern = "(Date[:]([\w-\s]*)\s*)\n"
.Global = False

Case 3
.Pattern = "(([\d]*\.[\d]*))\s*\n"
.Global = False
End Select

End With
If Reg1.test(sText) Then

' each "(\w*)" and the "(\d)" are assigned a vText variable
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 M = Nothing
Set M1 = Nothing
Set Reg1 = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub

I want to run it form Outlook Rules and I don't know how

 

[Diane Poremsky]

This snippet *should* work - copy each case block to cover all of the sections you need to find and adjust the i = 3 line to reflect the correct number. Add an if i = nn lines as needed.

The pattern for the phone # will be something like this, assuming they always use the pattern in your example.
((\([0-9]{3}\)-([0-9]{3})-([0-9]{4}))

For i = 1 To 3
With Reg1

Select Case i
Case 1 ' assumes always starts with C
.Pattern = "(referenciado es (C[\d]*))\n"
.Global = False

Case 2 ' always numbers
.Pattern = "(Store #([\d]*))\n"
.Global = False

Case 3 ' always letters
.Pattern = "(PR, PR,([\w]*)\n"
.Global = False

End Select

End With
If Reg1.test(sText) Then

' each "(\w*)" and the "(\d)" are assigned a vText variable
Set M1 = Reg1.Execute(sText)
For Each M In M1

   Debug.Print M.SubMatches(1)
            strResult= M.SubMatches(1)
     If i = 1 then vText = StrResult
     If i = 2 then vText2 = StrResult
     If i = 3 then vText3 = StrResult
   
Next
End If

 

[Wichiepr]

First Thanks for taking your time, I try the Macro and try to add some other other patter like this and I am getting and error on the Select i, I really don't know how to proceed

For i = 1 To 3

Option Explicit
Private Const xlUp As Long = -4162
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 rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim Reg1 As Object
Dim M1 As Object
Dim M As Object

enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Canvas\emails.xlsx"
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("Data")
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1

sText = olItem.Body
Set Reg1 = CreateObject("VBScript.RegExp")
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric

For i = 1 To 3
With Reg1
Select Case i
Case 1
.Pattern = "(Order ID\s[:]([\w-\s]*)\s*)\n"
.Global = False

Case 2
.Pattern = "(Date[:]([\w-\s]*)\s*)\n"
.Global = False

Case 3
.Pattern = "(([\d]*\.[\d]*))\s*\n"
.Global = False
End Select

End With
If Reg1.test(sText) Then

' each "(\w*)" and the "(\d)" are assigned a vText variable
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 M = Nothing
Set M1 = Nothing
Set Reg1 = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub

I want to run it form Outlook Rules and I don't know how

 

[Diane Poremsky]

Well, for starters, For i = 1 To 3 shouldn't be above option explicit.

Do you want everything in column B? (Records are usually put in rows.)

This works here - when you use wildcards (.*), you need to have a unique word to search on.

This should work as a rule - it needs ot be in a module, not in thisoutlooksession.

Option Explicit
Private Const xlUp As Long = -4162

Private Sub CopyToExcel(olItem As Outlook.MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText, vText2, vText3, vText4, vText5, vText6, vText7 As Variant
Dim sText As String
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim Reg1 As Object
Dim M1 As Object
Dim M As Object
Dim i
Dim strResult As String

enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Canvas\emails.xlsx"
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("Data")
Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1

sText = olItem.Body
Set Reg1 = CreateObject("VBScript.RegExp")
For i = 1 To 7

With Reg1

Select Case i
' El número de orden de trabajo referenciado es C5937015 Cell B-1
Case 1 ' assumes always starts with C
.Pattern = "(referenciado es (C[\d]*))"
.Global = False

'Edificio: Store #12012 Cell B-2
Case 2 ' always numbers
.Pattern = "(Store #([\d]*))"
.Global = False

'Prioridad: P3 - Alto Cell B-3
Case 3
.Pattern = "(Prioridad:\s*(.*))\r"
.Global = False

'País, Estado, Ciudad: PR, PR, Fajardo Cell B-4
Case 4 ' always letters
.Pattern = "(PR, PR,\s*(.*))\r"
.Global = False

'Piso: All: 100 CALLE 12
Case 5
.Pattern = "(All: (.*))\r"
.Global = False

'Nombre de contacto: NORAIVETTE GONZALEZ
Case 6
.Pattern = "(contacto: ([\w ]*))"
.Global = False

'Teléfono de contacto: (787) 863-1475 Cell 7
Case 7
.Pattern = "(Teléfono de contacto:\s*(.*))\r"
.Global = False

End Select

End With

If Reg1.Test(sText) Then

Set M1 = Reg1.Execute(sText)
For Each M In M1

Debug.Print M.SubMatches(1)
strResult = M.SubMatches(1)
If i = 1 Then vText = strResult
If i = 2 Then vText2 = strResult
If i = 3 Then vText3 = strResult
If i = 4 Then vText4 = strResult
If i = 5 Then vText5 = strResult
If i = 6 Then vText6 = strResult
If i = 7 Then vText7 = strResult

Next
End If
Next i
Debug.Print vText
Debug.Print "2: " & vText2
Debug.Print "3: " & vText3
Debug.Print "4: " & vText4
Debug.Print "5: " & vText5
Debug.Print "6: " & vText6
Debug.Print "7: " & vText7

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 M = Nothing
Set M1 = Nothing
Set Reg1 = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub

If you want to test it on messages in your mailbox,
run this macro:

Sub TestMacro()
Dim olItem As Outlook.MailItem
Set olItem = Application.ActiveExplorer.Selection.Item(1)
CopyToExcel olItem
End Sub

 

[Wichiepr]

Well, for starters, For i = 1 To 3 shouldn't be above option explicit.

Do you want everything in column B? (Records are usually put in rows.)

This works here - when you use wildcards (.*), you need to have a unique word to search on.

This should work as a rule - it needs ot be in a module, not in thisoutlooksession.

Option Explicit
Private Const xlUp As Long = -4162

Private Sub CopyToExcel(olItem As Outlook.MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText, vText2, vText3, vText4, vText5, vText6, vText7 As Variant
Dim sText As String
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim Reg1 As Object
Dim M1 As Object
Dim M As Object
Dim i
Dim strResult As String

enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Canvas\emails.xlsx"
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("Data")
Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1

sText = olItem.Body
Set Reg1 = CreateObject("VBScript.RegExp")
For i = 1 To 7

With Reg1

Select Case i
' El número de orden de trabajo referenciado es C5937015 Cell B-1
Case 1 ' assumes always starts with C
.Pattern = "(referenciado es (C[\d]*))"
.Global = False

'Edificio: Store #12012 Cell B-2
Case 2 ' always numbers
.Pattern = "(Store #([\d]*))"
.Global = False

'Prioridad: P3 - Alto Cell B-3
Case 3
.Pattern = "(Prioridad:\s*(.*))\r"
.Global = False

'País, Estado, Ciudad: PR, PR, Fajardo Cell B-4
Case 4 ' always letters
.Pattern = "(PR, PR,\s*(.*))\r"
.Global = False

'Piso: All: 100 CALLE 12
Case 5
.Pattern = "(All: (.*))\r"
.Global = False

'Nombre de contacto: NORAIVETTE GONZALEZ
Case 6
.Pattern = "(contacto: ([\w ]*))"
.Global = False

'Teléfono de contacto: (787) 863-1475 Cell 7
Case 7
.Pattern = "(Teléfono de contacto:\s*(.*))\r"
.Global = False

End Select

End With

If Reg1.Test(sText) Then

Set M1 = Reg1.Execute(sText)
For Each M In M1

Debug.Print M.SubMatches(1)
strResult = M.SubMatches(1)
If i = 1 Then vText = strResult
If i = 2 Then vText2 = strResult
If i = 3 Then vText3 = strResult
If i = 4 Then vText4 = strResult
If i = 5 Then vText5 = strResult
If i = 6 Then vText6 = strResult
If i = 7 Then vText7 = strResult

Next
End If
Next i
Debug.Print vText
Debug.Print "2: " & vText2
Debug.Print "3: " & vText3
Debug.Print "4: " & vText4
Debug.Print "5: " & vText5
Debug.Print "6: " & vText6
Debug.Print "7: " & vText7

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 M = Nothing
Set M1 = Nothing
Set Reg1 = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub

If you want to test it on messages in your mailbox,
run this macro:

Sub TestMacro()
Dim olItem As Outlook.MailItem
Set olItem = Application.ActiveExplorer.Selection.Item(1)
CopyToExcel olItem
End Sub