Visual Basic como copiar tabela do corpo do e-mail outlook com vba excel?

[Flávia de Oliveira Batista]

Boa tarde, pessoal. Estou com uma dúvida em código VBA. poderiam me ajudar, por favor?

Desde já agradeço.

 

Tenho necessidade de copiar algumas tabelas do corpo do e-mail do outlook e colar em uma planilha de excel.

Achei um código na internet que faz isso de forma muito eficiente, porém a programação é feita a partir do VBA dentro outlook, por assim dizer (abro o e-mail, clico Alt+f11 e aí abre uma tela de VBA, então colo o código e ele copia a tabela pra uma pasta excel).

queria saber se tem como fazer a partir do próprio excel, pois quero fazer interação com outras programações que utilizo.

Sub ImportTableToExcel()
Dim xMailItem As MailItem
Dim xTable As Word.Table
Dim xDoc As Word.Document
Dim xExcel As Excel.Application
Dim xWb As Workbook
Dim xWs As Worksheet
Dim I As Integer
Dim xRow As Integer
On Error Resume Next
Set xExcel = New Excel.Application
Set xWb = xExcel.Workbooks.Add
xExcel.Visible = True
Set xWs = xWb.Sheets(1)
xRow = 1
For Each xMailItem In Application.ActiveExplorer.Selection
    Set xDoc = xMailItem.GetInspector.WordEditor
    For I = 1 To xDoc.Tables.Count
        Set xTable = xDoc.Tables(I)
        xTable.Range.Copy
        xWs.Paste
        xRow = xRow + xTable.Rows.Count + 1
        xWs.Range("A" & CStr(xRow)).Select
    Next
Next
End Sub

origem do código

 

 

 

 

 

[Midori]

@Flávia de Oliveira Batista O código modificado para executar a partir do Excel. Deixe o Outlook aberto antes de rodar e ative as referências Microsoft Outlook e Word na planilha.

 

Sub ImportTableToExcel()
Dim xOutlook    As New Outlook.Application
Dim xMailItem   As MailItem
Dim xTable      As Word.Table
Dim xDoc        As Word.Document
Dim xWs         As Worksheet
Dim I           As Integer
Dim xRow        As Integer

On Error Resume Next

Set xWs = ThisWorkbook.ActiveSheet
xRow = 1

For Each xMailItem In xOutlook.Application.ActiveExplorer.Selection
    Set xDoc = xMailItem.GetInspector.WordEditor

    For I = 1 To xDoc.Tables.Count
        Set xTable = xDoc.Tables(I)
        
        xTable.Range.Copy
        xWs.Paste
        xRow = xRow + xTable.Rows.Count + 1
        xWs.Range("A" & CStr(xRow)).Select
    Next
Next
End Sub

 

[Flávia de Oliveira Batista]

@Midori  FUNCIONOU PERFEITAMENTE!

OBRIGADA.

 

BOA TARDE ;**