Public Sub MSG()
    
    Dim objOutlApp As Object, oNSpace As Object, oIncoming As Object
    Dim oIncMails As Object, oMail As Object
    Dim IsNotAppRun As Boolean
    Application.Calculation = xlCalculationManual

    On Error Resume Next
    Set objOutlApp = New Outlook.Application
    If objOutlApp Is Nothing Then ' даже к закрытому
        Set objOutlApp = CreateObject("outlook.Application")
        IsNotAppRun = True
    End If

    Set oNSpace = objOutlApp.GetNamespace("MAPI")
    Set oIncoming = oNSpace.Folders("mail@mail.ru").Folders("ПОСТУПЛЕНИЯ")   
    Set oIncMails = oIncoming.Items    
    
    Dim nn As Long
    nn = oIncMails.Count ' сколько всего пришло писем    
    If nn = 0 Then
        MsgBox "Новых писем - нет", Title:="ПОСТУПЛЕНИЯ"
        Exit Sub
    End If
    I = 1   
    Dim m As Long ' счетчик для цикла
    m = 0    
    For Each oMail In oIncMails
        m = m + 1
        Application.StatusBar = "Обработка " & m & "-го письма из " & nn
    
        ...  ' код обработки
    
'    завершение цикла по строке
    Next
    
End Sub

Sub SendHTTPRequest()
    
    Dim httpReq As Object
    Set httpReq = CreateObject("MSXML2.XMLHTTP")

    httpReq.Open "GET", "https://m4d.nalog.gov.ru/emchd/get-info/data", False

    httpReq.setRequestHeader "Content-Type", "application/json"

    httpReq.Send

    If httpReq.Status = 200 Then
        Debug.Print httpReq.responseText
    Else
        Debug.Print "Ошибка: " & httpReq.Status
    End If
    
    Set httpReq = Nothing
    
End Sub

Option Explicit
'   https://stackoverflow.com/a/35296933

 Sub importMsg()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False

    Dim i As Long
    Dim inPath As String
    Dim thisFile As String
'    Dim Msg As MailItem
    Dim ws As Worksheet
'    Dim myOlApp As Outlook.Application
    Dim myOlApp As Object ' Object/Application
'    Dim MyItem As Outlook.MailItem
    Dim MyItem As Variant ' Variant/Object/MailItem

    Set myOlApp = CreateObject("Outlook.Application")
    Set ws = ThisWorkbook.Worksheets(1)

    With Application.FileDialog(msoFileDialogFolderPicker)
       .AllowMultiSelect = False
            If .Show = False Then
                Exit Sub
            End If
        On Error Resume Next
        inPath = .SelectedItems(1) & "\"
    End With
    thisFile = Dir(inPath & "*.msg")
    i = 4

    Sheets(1).Cells.Clear

    Do While thisFile <> ""
        Set MyItem = myOlApp.CreateItemFromTemplate(inPath & thisFile)
        ws.Cells(i, 1) = MyItem.Body
        
'        -----извлечение номера-----
        Dim myRegExp As Object, myObj As Object, myStr1 As Object
        Dim msgText As String, myStr2 As String
        msgText = ws.Cells(i, 1)
        Set myRegExp = CreateObject("VBScript.RegExp")
        With myRegExp
            .Global = True
            .Pattern = "\d{2}\s\d{2}\s[№]\s\d{5,6}"
            Set myObj = .Execute(msgText)
        End With
        For Each myStr1 In myObj
            myStr2 = myStr1.Value
        Next myStr1
        ws.Cells(i, 2) = myStr2
        
'Как здесь переименовывать каждый *.msg в имя из ws.Cells(i, 2) = myStr2?

        i = i + 1
        thisFile = Dir()
    Loop

    Sheets(1).UsedRange.Columns.AutoFit

    Set MyItem = Nothing
    Set myOlApp = Nothing

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
End Sub