Exporting Email Table Data from Outlook

[CopyCatCoder]

Can somebody help me. This code works fine but I get Run Time Error 13 Type Mismatch error when loop comes to Meeting Request/Appointment/Task in outlook. The error comes at end of the loop i.e. Next OLMAIL. I am not able to trap it. On Error Resume Next is not working. I got another workaround If Not TypeName(OLMAIL) = "MailItem" Then MsgBox "not a mail item" but unsure where and how to put it in the code.

Secondly If OLMAIL.SentOn > CDate("2024-4-30 23:17:00") And Left(Trim(OLMAIL.Subject), 5) = "Recon" Then

If I switch on this condition how to skip Re and Fw emails in the code.

Sub ExtractTableDataFromOutlookEmails()

Range("A1:x1500").Clear

Dim OLApp As 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("email address removed for privacy reasons").Folders("sent items")

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
Dim olmType As String

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

'If OLMAIL.SentOn > CDate("2024-4-30 23:17:00") And Left(Trim(OLMAIL.Subject), 5) = "Recon" Then

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" & 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

Cells(eRow, 1) = "Senders Name: " & " " & OLMAIL.Sender
Cells(eRow, 2) = "Date & Time of Sent: " & " " & OLMAIL.SentOn
Cells(eRow, 3) = "Subject: " & " " & OLMAIL.Subject

Next t
' End If

If Not TypeName(OLMAIL) = "MailItem" Then MsgBox "not a mail item"

Next OLMAIL

Range("A1").Select

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

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

End Sub

[#2 · Accepted solution]

@CopyCatCoder 

To address the issues you mentioned:

1. To avoid the "Type Mismatch" error when encountering items other than mail items in the Outlook folder, you can use a conditional statement to check if the item is a MailItem before proceeding with the processing. You can place this check inside your loop before processing each item.
2. To skip emails with subjects starting with "Re" or "Fw", you can add an additional condition within your loop to check if the subject of the email does not start with "Re" or "Fw".

Here is your modified code with these adjustments:

Vba code is untested; please backup your file before you use the code.

Sub ExtractTableDataFromOutlookEmails()
    Range("A1:X1500").Clear
    
    Dim OLApp As 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("email address removed for privacy reasons").Folders("sent items")
    
    Dim OLMAIL As Object ' Use Object type to handle different item types
    
    Dim oHTML As MSHTML.HTMLDocument
    Set oHTML = New MSHTML.HTMLDocument
    Dim oElColl As MSHTML.IHTMLElementCollection
    
    Dim t As Long, r As Long, c As Long
    Dim eRow As Long
    
    For Each OLMAIL In MYFOLDER.Items
        If TypeName(OLMAIL) = "MailItem" Then ' Check if the item is a MailItem
            If OLMAIL.SentOn > CDate("2024-4-30 23:17:00") And Left(Trim(OLMAIL.Subject), 5) = "Recon" Then
                With oHTML
                    .Body.innerHTML = OLMAIL.HTMLBody
                    Set oElColl = .getElementsByTagName("table")
                End With
                
                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" & 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
                    Cells(eRow, 1) = "Sender's Name: " & " " & OLMAIL.Sender
                    Cells(eRow, 2) = "Date & Time of Sent: " & " " & OLMAIL.SentOn
                    Cells(eRow, 3) = "Subject: " & " " & OLMAIL.Subject
                Next t
            End If
        End If
    Next OLMAIL
    
    Range("A1").Select
    
    Set OLApp = Nothing
    Set OLMAIL = Nothing
    Set oHTML = Nothing
    Set oElColl = Nothing
End Sub

This code should address both the "Type Mismatch" error and the condition to skip emails with subjects starting with "Re" or "Fw". The text, steps and code were created with the help of AI.

My answers are voluntary and without guarantee!

Hope this will help you.

Was the answer useful? Mark as best response and Like it!

This will help all forum participants.