Блог

У меня есть код VBA, который извлекает таблицы из электронных писем Outlook.

У меня есть подпапка в разделе «Входящие», в которую входят все похожие письма.

Я хочу извлечь данные на основе темы письма, вместо того, чтобы иметь выделенную подпапку для этого конкретного письма.

Код ниже.

 Option Explicit

Sub ImportTable()

Cells.Clear
Dim OLApp As Outlook.Application
'Set OA = CreateObject("Outlook.Application")
Set OLApp = New Outlook.Application

Dim ONS As Outlook.Namespace
Set ONS = OLApp.GetNamespace("MAPI")
Dim myFolder As Outlook.Folder
Set myFolder = ONS.Folders("emailaddress").Folders("Inbox")
Set myFolder = myFolder.Folders("Others")
Dim OLMAIL As Outlook.MailItem
Set OLMAIL = OLApp.CreateItem(olMailItem)

For Each OLMAIL In myFolder.Items
    Dim oHTML As MSHTML.HTMLDocument
    Set oHTML = New MSHTML.HTMLDocument
    Dim oElColl As MSHTML.IHTMLElementCollection
    With oHTML
        .Body.innerHTML = OLMAIL.HTMLBody
        Set oElColl = .getElementsByTagName("table")
    End With

    Dim t As Long, r As Long, c As Long
    Dim eRow As Long

    For t = 0 To oElColl.Length - 1
        eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        For r = 0 To (oElColl(t).Rows.Length - 1)
            For c = 0 To (oElColl(t).Rows(r).Cells.Length - 1)
                Range("A" amp; eRow).Offset(r, c).Value = oElColl(t).Rows(r).Cells(c).innerText
            Next c
        Next r
        eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    Next t
        
    'Cells(eRow, 1) = "Sender's Name:" amp; " " amp; OLMAIL.Sender
    'Cells(eRow, 1).Interior.Color = vbRed
    'Cells(eRow, 1).Font.Color = vbWhite
    Cells(eRow, 1) = "Date amp; Time of Receipt:" amp; " " amp; OLMAIL.ReceivedTime
    Cells(eRow, 1).Interior.Color = vbRed
    Cells(eRow, 1).Font.Color = vbWhite
    Cells(eRow, 1).Columns.AutoFit
        
Next OLMAIL

Range("A1").Select

Set OLApp = Nothing
Set OLMAIL = Nothing
Set oHTML = Nothing
Set oElColl = Nothing

On Error Resume Next
Range("A1:A" amp; Worksheets(1).UsedRange.Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

'ThisWorkbook.VBProject.VBE.MainWindow.Visible = False

End Sub
 

Если вы хотите иметь дело с входящими электронными письмами, посмотрите ссылку на веб-сайт, который я поместил в комментарии выше.

Если вы хотите разобраться с текущим элементом, есть несколько способов сделать это. Вот один из способов, который я недавно нашел, и он потрясающий, и я его использую! Нажмите здесь, чтобы перейти на веб-сайт.

Я внес изменения в соответствии с вашими потребностями. Если у вас разные темы, он уверен, что содержимое для извлечения также будет отличаться, поэтому он проверяет текущий элемент и запускает определенный макрос в зависимости от темы.

Вставьте код в модуль ThisOutlookSession

 Private WithEvents m_Inspectors As Outlook.Inspectors
Private WithEvents m_Inspector As Outlook.Inspector
  
Private Sub Application_Startup()
 Set m_Inspectors = Application.Inspectors
End Sub
  
Private Sub m_Inspectors_NewInspector(ByVal Inspector As Outlook.Inspector)
 If TypeOf Inspector.currentItem Is Outlook.MailItem Then
  'Handle emails only
  Set m_Inspector = Inspector
 End If
End Sub
  
Private Sub m_Inspector_Activate()
    Dim Item As MailItem
    
    If TypeOf m_Inspector.currentItem Is MailItem Then
        Set Item = m_Inspector.currentItem
        
        With Item
            ' Display mail
            '.Display
            
            ' Mails with filled opions
            Select Case .subject
                Case "mySubject_01"
                    Call Macro_01
                    
                Case "mySubject_02"
                    Call Macro_02
                    
                Case "mySubject_03"
                    Call Macro_03
            End Select
            
            Set Item = Nothing
        End With
    End If
End Sub