extract table from outlook email

[malpa]

Hi

I receive a lot of emials.
That i Want is identify a html format, to export valules that comes into a table, to a excel application, automatically.

I am running this script like a rule.

The problem is that my initial scrpit, not function when the table into email with html format, comes in a different position, because i am reading it like a text format.

I tried to change especial characters like vbCrLf by ";", but if the table change the position, i could not find the values at the same position.

I appreciated your comments, I want to read this email like a html format, to identify the tags.


Sub GetData()

Dim msg As Outlook.MailItem
Dim rows As Variant
Dim numberofColumns As Long
Dim numberofRows As Long
Dim headerValues As Variant
Dim headerRow() As String
Dim data() As String
Dim i As Long, k As Long, j As Long
Dim cont As String
Dim Val As String



Dim myXLApp As Excel.Application
Dim myXLWB As Excel.Workbook
Dim Asunto As String
Dim TotalRows As Integer


Dim objRegExp As RegExp
Dim objMatch As Match
Dim colMatches As MatchCollection
Dim RetStr As String
Dim cadena As String
Dim Ncadena As String
Dim myPattern As String


Set msg = ActiveExplorer.Selection.item(1)
Set myXLApp = New Excel.Application
myXLApp.Visible = True
Set myXLWB = myXLApp.Workbooks.Open("D:\ibague_sigma\UMTS\ControlIncidenciasUmts.xls")

'Val= "<table[^>] >.+</table>"
'Val= "<tr[^>] >.+</tr>"
'Val= "<td[^>] >.+</td>"
'Val = Chr(13) & Chr(10) & " "

msg.Body = Replace(msg.Body, vbCrLf, ";")



Set objRegExp = New RegExp
objRegExp.Pattern = ";+"

objRegExp.IgnoreCase = True
objRegExp.Global = True
'msg.Body
If (objRegExp.Test(msg.Body) = True) Then
MsgBox objRegExp.Replace(msg.Body, ";")
msg.Body = msg.Body & vbCrLf & objRegExp.Replace(msg.Body, ";")
rows = Split(objRegExp.Replace(msg.Body, ";"), ";")
End If


'La última
TotalRows = Sheets(1).Range("A65536").End(xlUp).Row
j = TotalRows + 1

Asunto = msg.Subject

For i = LBound(rows) To UBound(rows)
MsgBox rows(i)
cont = cont & vbCrLf & i & ";" & rows(i)
MsgBox cont
Next

With myXLWB.Worksheets(1)
.cells(j, 1).Value = Asunto
.cells(j, 2).Value = rows(2)
.cells(j, 3).Value = rows(6)
.cells(j, 4).Value = rows(9)
.cells(j, 5).Value = rows(10)
.cells(j, 6).Value = rows(17)
.cells(j, 7).Value = rows(23)
.cells(j, 8).Value = rows(27)
.cells(j, 9).Value = rows(31)
.cells(j, 10).Value = rows(36)
.cells(j, 11).Value = rows(40)
.cells(j, 12).Value = rows(48)
.cells(j, 13).Value = rows(54)
.cells(j, 14).Value = rows(60)
.cells(j, 15).Value = rows(66)
.cells(j, 16).Value = rows(72)
.cells(j, 17).Value = rows(78)
.cells(j, 18).Value = rows(84)
.cells(j, 19).Value = rows(90)
End With

msg.Body = cont

myXLWB.Save
myXLWB.Close


End Sub


thanks a lot
Malpa

 

[UnsolvedCoding]

I would suggest writting something that will search for column headings and re-arrange or rename them as needed.

 

[malpa]

Hi

Thanks a lot for your answer UnsolvedCoding, the issue was solved . Further, I include this script into the thisoutlooksession module, and it works fine.

The next steep will be open the excel file attachement and save it.

Any suggestion? I appreciated your comments.


Tanks Malpa.

For me VBA is a new lenguage, but this is My little contribution to tek.tips family.

THE CODE :

'Definimos el objeto myMessage
Dim strEmbeddedImageTag As String
Dim strStyle As String
Dim strReplaceThis As String
Dim intX As Integer, intY As Integer, i As Integer, j As Integer, k As Integer

Dim myMessage As Outlook.MailItem

Dim filas As Variant
Dim Arr()
Dim Variable As Integer
Dim Variable2
Dim Variable3


Dim objRegExp As RegExp
Dim objMatch As Match
Dim colMatches As MatchCollection
Dim RetStr As String
Dim myarray
Dim Txt As String
RegExp = " "


Dim myXLApp As Excel.Application
Dim myXLWB As Excel.Workbook
Dim Asunto As String
Dim TotalRows As Integer





Set myXLApp = New Excel.Application




myXLApp.Visible = False
Set myXLWB = myXLApp.Workbooks.Open("D:\file.xls")

'Calcula La ultima
TotalRows = myXLWB.Sheets("EmailData").Range("A65536").End(xlUp).Row
z = TotalRows + 1
col = 1
Arr = Array(".2.", ".4.", ".5.", ".7.", ".8.", ".10.", ".12.", ".14.", ".16.", ".18.", ".21.", ".23.", ".25.", ".27.", ".29.", ".31.", ".33.", ".35.")



'Pattern
'
myPattern = "<[^>]*>"
myPattern1 = "<o\>\&nbsp\;<\/o\>"
myPattern1 = "<o\>\&nbsp\;<\/o\><\/span><\/font><\/p> *<\/td> *<\/tr>"
myPattern2 = Chr(13) & Chr(10) & " "



'Create a regular expression object.
Set objRegExp = New RegExp
'Set the pattern by using the Pattern property.
' objRegExp.Pattern = myPattern

'Set Case Insensitivity.
objRegExp.IgnoreCase = True
'Set global applicability.
objRegExp.Global = True


Select Case TypeName(Outlook.Application.ActiveWindow)
Case "Explorer"
Set myMessage = ActiveExplorer.Selection.item(1)
Case "Inspector"
Set myMessage = ActiveInspector.CurrentItem
Case Else
MsgBox ("No message selected.")
Exit Sub
End Select

Asunto = myMessage.Subject
myXLWB.Sheets("EmailData").cells(z, col) = Asunto

intX = InStr(1, myMessage.HTMLBody, "<table ", vbTextCompare)
intY = InStr(intX, myMessage.HTMLBody, "</table>", vbTextCompare)
myMessage.HTMLBody = Mid(myMessage.HTMLBody, intX, intY - intX + 8)
'myMessage.Save

filas = Split(myMessage.HTMLBody, "<tr ") ' Lineas

intX = 0
intY = 0
Variable = 0

For i = 1 To UBound(filas)
'MsgBox filas(i)
columnas = Split(filas(i), "<td ")

For j = 0 To UBound(columnas) ' celdas
'MsgBox columnas(j)
sp = Split(columnas(j), "<p")
'MsgBox UBound(sp)

For k = LBound(sp) To UBound(sp) ' cantidad de comentarios que no contengan
objRegExp.Pattern = myPattern1 ' "<o\>\&nbsp\;<\/o\>"
columnas(j) = Replace(columnas(j), vbCrLf, "")
'MsgBox columnas(j)
If (objRegExp.Test(columnas(j)) = False) Then ' sino contiene nbsp continuamos
intX = InStr(1 + intX, columnas(j), "<p", vbTextCompare)
If intX > 0 Then
'columnas(j) = "<" & Replace(columnas(j), vbCrLf, "")
'MsgBox columnas(j)
intY = InStr(intX, columnas(j), "</p>", vbTextCompare)
strReplaceThis = Mid(columnas(j), intX, intY - intX)
objRegExp.Pattern = myPattern ' Solo dejamos comentarios por cada span "<[^>]*>"
If (objRegExp.Test(strReplaceThis) = True) Then
res = res & objRegExp.Replace(strReplaceThis, "") ' concatenamos span

'MsgBox res & "-" & Variable
Variable3 = Variable3 + 1
If Variable3 <= 1 Then
Variable = Variable + 1
End If

End If
'MsgBox strReplaceThis

End If

End If

Next
Variable3 = 0


Variable2 = Filter(Arr, "." & Variable & ".", True, vbBinaryCompare)
If UBound(Variable2) = 0 And res <> "" Then
'MsgBox Variable & " -" & res & "fin"
col = col + 1
myXLWB.Sheets("EmailData").cells(z, col) = res
End If
res = ""
Next
Next

myXLWB.Save
myXLWB.Close (True)
myXLApp.Workbooks.Close
Set myXLWB = Nothing
myXLApp.Application.Quit
Set myXLApp = Nothing