Const olFolderCalendar =  9 
Const olFolderContacts =  10 
Const olFolderDeletedItems =  3 
Const olFolderDrafts =  16  '(&H10)
Const olFolderInbox =  6 
Const olFolderJournal =  11 
Const olFolderNotes =  12 
Const olFolderOutbox =  4 
Const olFolderSentMail =  5 
Const olFolderTasks =  13 
Const olPublicFoldersAllPublicFolders =  18  '(&H12)


Sub ReadBox()
    ListAllItemsInInbox_for_Outlook_macros (olFolderInbox)
End Sub
Sub ListAllItemsInInbox_for_Outlook_macros(BoxIndex)
Dim OLF As Object, CurrUser As String
Dim EmailItemCount As Integer, i As Integer, EmailCount As Integer
    
    MailInDir = "D:\Outlook\"
    Set OLF = GetObject("", "Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(BoxIndex)
    EmailItemCount = OLF.Items.Count
    i =  0 : EmailCount =  0 
    
    While i < EmailItemCount
        i = i +  1 
        i1 =  0 
        With OLF.Items(i)
        If .UnRead Then
            While i1 < .Attachments.Count
                i1 = i1 +  1 
                .Attachments(i1).SaveAsFile MailInDir & .Attachments(i1).FileName
            Wend
           
        End If
        End With
    Wend
    Set OLF = Nothing
    UserForm1.Show
    
    
End Sub

Для этого в модуле напишите:

Option Explicit

Public Declare Function SetWindowPos& Lib "user32" (ByVal hwnd As Long, _
ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long)

Const HWND_TOPMOST = - 1 
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2

Public Sub StayOnTop(ByRef objFrm As Form)

    SetWindowPos objFrm.hwnd, HWND_TOPMOST,  0 ,  0 ,  0 ,  0 , SWP_NOMOVE Or SWP_NOSIZE

End Sub

Const olFolderCalendar =  9 
Const olFolderContacts =  10 
Const olFolderDeletedItems =  3 
Const olFolderDrafts =  16  '(&H10)
Const olFolderInbox =  6 
Const olFolderJournal =  11 
Const olFolderNotes =  12 
Const olFolderOutbox =  4 
Const olFolderSentMail =  5 
Const olFolderTasks =  13 
Const olPublicFoldersAllPublicFolders =  18  '(&H12)
Sub ReadBox()
    ListAllItemsInInbox_for_Outlook_macros (olFolderInbox)
End Sub
Sub ListAllItemsInInbox_for_Outlook_macros(BoxIndex)
Dim OLF As Object, CurrUser As String
Dim EmailItemCount As Integer, i As Integer, EmailCount As Integer
    
    MailInDir = "D:\Outlook"
    Set OLF = GetObject("", "Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(BoxIndex)
    EmailItemCount = OLF.Items.Count
    i =  0 : EmailCount =  0 
    ' read e-mail information
    BoxText = "тра-ля-ля:" + Chr( 10 ) + Chr( 10 )
    While i < EmailItemCount
        i = i +  1 
       
        i1 =  0 
        With OLF.Items(i)
        If .UnRead Then
            While i1 < .Attachments.Count
                i1 = i1 +  1 
                .Attachments(i1).SaveAsFile MailInDir & .Attachments(i1).FileName
            Wend
           
           End If
        End With
    Wend
    Set OLF = Nothing
    MsgBox BoxText
    BoxText = BoxText + Chr( 10 ) & "Вложения распакованы в папку " + MailInDir + Chr( 10 )
    BoxText = "Письмо пришло"
    
End Sub

  Private Sub Application_NewMail()
    
   ListAllItemsInInbox_for_Outlook_macros (olFolderInbox)
   End Sub
   Function sound(x0, x1, x2, x3)
   For i0 =  1  To x0
    
    For i1 =  1  To x1
        Beep
        For i2 =  1  To x2
       
        Next
        
    Next
    
    
    For i3 =  1  To x3
        q = q *  10000  /  20000 
    Next
Next
End Function