[Outlook 2010] Macro to import data from incoming emails

Hello Guys.
I am new to the forum so any error posting, forgive me.
I need to extract data from the inbox of the outlook, but only the emails that were answered by me. In case, must contain the following information: Date/time received, office, department, date of response, email the person who sent it.
I elaborated the following macro however is not doing what I want.

Sub fncRelatório()
    'Execute esta macro no Outlook
    
    'Altere o caminho abaixo
    Const cstrOutput As String = "c:\temp\Relatório.txt"

    Dim intFF As Integer
    Dim lngMonth As Long
    Dim lngYear As Long
    Dim mli As MailItem
    Dim rcp As Recipient
    Dim ctt As ContactItem
    Dim nms As NameSpace
    Dim objAllItems As Outlook.Items
    Dim objFilteredItems As Outlook.Items
    Dim objItem As Object
    Dim strCriteria As String
    Dim strDepartament As String
    Dim strOfficeLocation As String
 
    lngYear = InputBox("Type the year:", , Year(Date))
    lngMonth = InputBox("Type the month:", , Month(Date))
 
    If lngYear < 1900 Or lngYear > 3000 Or lngMonth < 1 Or lngMonth > 12 Then
        MsgBox "Dados de entrada incorretos.", vbCritical
        Exit Sub
    End If
 
    Set nms = Application.GetNamespace("MAPI")
    'Altere as pastas abaixo para como está configurado seu e-mail:
    Set objAllItems = nms.Folders("your@emailcom").Folders("Inbox").Items
    
    strCriteria = "[ReceivedTime] > " & "'" & DateSerial(lngYear, lngMonth, 1) & "'" _
    & " And [ReceivedTime] < " & "'" & DateSerial(lngYear, lngMonth + 1, 1) & "'"
    Set objFilteredItems = objAllItems.Restrict(strCriteria)

    intFF = FreeFile
    Open "c:\temp\Relatório.txt" For Output As #intFF
    For Each objItem In objFilteredItems
        If TypeName(objItem) = "MailItem" Then
            Set rcp = Nothing
            Set ctt = Nothing
            strDepartament = ""
            strOfficeLocation = ""
            Set rcp = mli.Recipients(1).Resolve
            If rcp.Resolved Then
                Set ctt = rcp.AddressEntry.GetContact
                If Not ctt Is Nothing Then
                    strDepartament = ctt.Department
                    strOfficeLocation = ctt.OfficeLocation
                End If
            End If
            Print #intFF, "Titulo: " & mli.Subject
            Print #intFF, "Destinatário: " & mli.To
            Print #intFF, "Departamento: " & strDepartament
            Print #intFF, "Local do Escritório: " & strOfficeLocation
            Print #intFF, "Data Envio: " & mli.SentOn
            Print #intFF, "Corpo da Mensagem: " & Left(mli.Body, 50)
            Print #intFF, ""
        End If
    Next objItem
    Close #intFF
End Sub

Could you help me please?

Thanked.

nobody ?