Регистрация входящих писем Outlook в Excel

Set sAccount = GetAccountByEmail(senderEmail, appOutlook)
 
...
 
Public Function GetAccountByEmail(ByVal accountEmail As String, ByRef oApp As Object) As Object
 
    Dim oAccount As Object
 
    For Each oAccount In oApp.Session.Accounts
    
        If oAccount.SmtpAddress Like accountEmail Then
        
            Set GetAccountByEmail = oAccount
            Exit Function
        
        End If
    
    Next
 
End Function

...
Set objFolder = objNamespace.GetDefaultFolder(6).Folders("Monitoring") '6=olFolderInbox
...

[VB]
Sub my_macros()
'
' my_macros Макрос
'
 
Dim objOutlook As Object, objNamespace As Object
Dim objFolder As Object, objMail As Object
Dim iRow&, iCount&, IdMail$
 
iRow = Cells(Rows.Count, "A").End(xlUp).Row
iCount = Application.Max(Range("A:A"))
 
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(6).Folders("Входящие") '6=olFolderInbox
 
 
Application.ScreenUpdating = False
 
'On Error Resume Next
For Each objMail In objFolder.Items
IdMail = objMail.EntryID
If Application.CountIf(Range("G:G"), IdMail) = 0 Then
iRow = iRow + 1: iCount = iCount + 1
Cells(iRow, 1) = iCount
Cells(iRow, 2) = objMail.SenderName
Cells(iRow, 3) = objMail.SenderEmailAddress
Cells(iRow, 4) = objMail.Subject
Cells(iRow, 5) = objMail.CreationTime
Cells(iRow, 6) = Left(objMail.Body, 100)
Cells(iRow, 7) = IdMail '"'" & IdMail
End If
Next
 
objOutlook.Quit
 
Application.ScreenUpdating = True
 
 
'
End Sub

Set objFolder = objNamespace.GetDefaultFolder(6).Folders("Входящие")'6=olFolderInbox