VBA error

[afteraincomesunshine]

Pls, help me to check this code. I would like to get the table from emails with the conditions that the day is today and find by the keyword from the subject. I ran the code but didn't receive any data. Thanks in advance.

>>> use code - tags <<<

Option Explicit

Sub importOutlookTableToExcel()

    Const myMail As String = "....@hotmail.com"
    Const Keyword As String = "FN IIC"
   
    ' Early Binding
    Dim oApp As Outlook.Application
    Dim oMapi As Outlook.MapiFolder
    Dim oItems As Outlook.Items
    Dim oMail As Outlook.MailItem
    Dim StartDate As Date
    Dim EndDate As Date
   
    On Error Resume Next
    Set oApp = GetObject(, "Outlook.Application")
    If oApp Is Nothing Then Set oApp = CreateObject("Outlook.Application")
    On Error GoTo 0
   
    Set oMapi = oApp.GetNamespace("MAPI").Folder(myMail).Folders("inbox")
    Set oItems = oMapi.Items
    Set oMail = oItems.Find("[Subject] like ""FN IIC"")
    Dim filteredItems As Outlook.Items
    Set filteredItems = oItems.Restrict("[Subject] Like '*" & Keyword & "*'")
   
    StartDate = DateValue("2023-06-02")
    EndDate = DateValue("2023-06-16")
   
    Dim html As MSHTML.HTMLDocument
    Set html = New MSHTML.HTMLDocument
    Dim htmlNodes As MSHTML.IHTMLElementCollection
   
    For Each oMail In filteredItems
        If(Instr(1, oMail.Subject, keyword, vbTextCompare) > 0) then
        With html
            .body.innerHTML = oMail.HTMLBody
            Set htmlNodes = .getElementsByTagName("table")
        End With
       
        Dim x As Long, y As Long, i As Long, tblbStartRow As Long
        tblbStartRow = 1 ' Initialize the starting row
        For i = 0 To htmlNodes.Length - 1
            tblbStartRow = (x + 1)
            Range("A" & tblbStartRow).Value = "Table " & (i + 1)
           
            For x = 0 To htmlNodes(i).Rows.Length - 1
                For y = 0 To htmlNodes(i).Rows(x).Cells.Length - 1
                    Range("C1").Offset(x + tblbStartRow - 1, y).Value = htmlNodes(i).Rows(x).Cells(y).innerText
                Next y
            Next x
        Next i
      End if
     Exit For          
    Next oMail
  
    Set oApp = Nothing
    Set oMapi = Nothing
    Set oItems = Nothing
    Set html = Nothing
    Set htmlNodes = Nothing
End Sub

 

[p45cal]

Did you edit the line:

Const myMail As String = "....@hotmail.com"

to suit your email?

 

[afteraincomesunshine]

Did you edit the line:

Const myMail As String = "....@hotmail.com"

to suit your email?

actually i filled out my email. but the code did't work. have you ever tested my case?

 

[p45cal]

have you ever tested my case?

No, I was looking for the obvious.
Let's get you over the first bit:

Sub importOutlookTableToExcel()

Const myMail As String = "...outlook.com"
Const Keyword As String = "FN IIC"
 
' Early Binding
Dim oApp As Outlook.Application
Dim oMapi As Outlook.MapiFolder
Dim oItems As Outlook.Items
Dim oMail As Outlook.MailItem
Dim StartDate As Date
Dim EndDate As Date
Dim filteredItems As Outlook.Items
Dim myFilter As String

On Error Resume Next
Set oApp = GetObject(, "Outlook.Application")
If oApp Is Nothing Then Set oApp = CreateObject("Outlook.Application")
On Error GoTo 0
 
Set oMapi = oApp.GetNamespace("MAPI").Folders(myMail).Folders("inbox")
Set oItems = oMapi.Items
myFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " LIKE '%" & Keyword & "%'"
Set filteredItems = oItems.Restrict(myFilter)

Note the s in
Set oMapi = oApp.GetNamespace("MAPI").Folders(myMail).Folders("inbox")