Sub СМС()

Dim XMLHTTP, XMLDoc As Object
Dim txt, Txt1, Txt0, Url As String

Dim dlina As Integer


Url = "https://fos.smedservice.ru/efrapi/auth/v1/login"

  Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")
  Set XMLDoc = CreateObject("MSXML2.DOMDocument")'не использую т к хз что это
  
  With XMLHTTP
   .Open "POST", Url, False
   .setRequestHeader "Content-type", "application/json"
   .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/86.0.4240.77 YaBrowser/20.11.0.821 Yowser/2.5 Safari/537.36"
   .send "{""login"":""******"",""passwd"":""*******""}"
    Debug.Print .Status; .statusText

Url = "https://fos.smedservice.ru/efrapi/insurance-service/v2/contracts/extract/?startDate=06.02.2021&endDate=06.02.2021&kind="
    
   .Open "GET", Url, False
   .setRequestHeader "Content-type", "application/json"
   .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/86.0.4240.77 YaBrowser/20.11.0.821 Yowser/2.5 Safari/537.36"
   .send
    Debug.Print .Status; .statusText
   
   dlina = Len(XMLHTTP.responseText)'Обрезаю кавычки, скобки и лишний текст
   txt = Right(XMLHTTP.responseText, dlina - 9)'Обрезаю кавычки, скобки и лишний текст

   dlina = Len(txt)'Обрезаю кавычки, скобки и лишний текст

   
   Txt0 = Left(txt, dlina - 2) & "/content/Отчёт по продажам с 2021-02-06 по 2021-02-06.xlsx" '/content/
   
   Txt1 = Left(txt, dlina - 2) & "/content"'не получается склеить "адресс ссылки"&переменная&"и снова текст" поэтому сделал так
   txt = Left(txt, dlina - 2) & "/status"'не получается склеить "адресс ссылки"&переменная&"и снова текст" поэтому сделал так

   
Url = "https://fos.smedservice.ru/efrapi/insurance-service/v2/contracts/extract/" & txt 
    .Open "GET", Url, False
   .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/86.0.4240.77 YaBrowser/20.11.0.821 Yowser/2.5 Safari/537.36"
   .send
    Debug.Print .Status; .statusText
    
Url = "https://fos.smedservice.ru/efrapi/insurance-service/v2/contracts/extract/" & Txt1
    .Open "GET", Url, False
   .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/86.0.4240.77 YaBrowser/20.11.0.821 Yowser/2.5 Safari/537.36"
   .send
    Debug.Print .Status; .statusText
   
'все что ниже попытки скачать методом тыка и понять что не так. Мне сказали что нужна ссылка на файл который я скачиваю. 
'Но файл то формируется каждый раз, поэтому статичной ссылки нет, а вот динамическую ссылку я не вижу через разработчика в браузере

    txt = Txt0 & Replace(.getResponseHeader("Content-Disposition"), "attachment; filename=", "")'Вычленяю имя файла хотя имя файла всего одно и тоже, меняется только дата в названии.
    
    Url = "https://fos.smedservice.ru/efrapi/insurance-service/v2/contracts/extract/" & Txt0
    .Open "GET", Url, False
   .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/86.0.4240.77 YaBrowser/20.11.0.821 Yowser/2.5 Safari/537.36"
   .send
    
    Debug.Print Url
    'Debug.Print txt
    Debug.Print .Status; .statusText
   'Debug.Print .responseText
   
   End With

End Sub

СодержимоеФайла= GetHTTPResponse (URL$, "utf-8") 

Function GetHTTPResponse(ByVal URL$, Optional ByVal Encoding$) As String
    On Error Resume Next
    Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP")
    With oXMLHTTP
        .Open "GET", URL$, False
        .Send
        If Len(Encoding$) Then
            With CreateObject("ADODB.Stream")
                filename$ = Environ("tmp") & "\response.txt"
                .Charset = Encoding$: .Type = 1        ' adTypeBinary:
                .Open: .Write oXMLHTTP.ResponseBody
                .SaveToFile filename$, 2
                .Type = 2        'adTypeText
                .LoadFromFile filename$
                GetHTTPResponse = .ReadText
                .Close
            End With
        Else
            GetHTTPResponse = .ResponseText
        End If
    End With
    Set oXMLHTTP = Nothing
End Function

Sub СМС_версия_2()
Dim XMLHTTP As Object
Dim txt, Txt1, Txt0, URL, Cookie1 As String
Dim dlina, status1 As Integer

Dim ADOStream As Object
Dim FolderSave$, FileName$
'Папка для сохранения файла
FolderSave = "C:\Users\***********"

URL = "https://fos.smedservice.ru/efrapi/auth/v1/login"

  Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")
  
  With XMLHTTP
   .Open "POST", URL, False
   .setRequestHeader "Content-type", "application/json"
   .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/86.0.4240.77 YaBrowser/20.11.0.821 Yowser/2.5 Safari/537.36"
   .send "{""login"":""******"",""passwd"":""********""}"
    Debug.Print .Status; .statusText; " POST Залогин"
    
    
    dlina = Len(XMLHTTP.getResponseHeader("Set-Cookie"))
    Cookie1 = Left(XMLHTTP.getResponseHeader("Set-Cookie"), dlina - 25)
    'Debug.Print Cookie1
    
URL = "https://fos.smedservice.ru/efrapi/insurance-service/v2/contracts/extract/?startDate=01.02.2021&endDate=07.02.2021&kind="
    
   .Open "GET", URL, False
   .setRequestHeader "Cookie", Cookie1
   .setRequestHeader "Content-type", "application/json"
   .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/86.0.4240.77 YaBrowser/20.11.0.821 Yowser/2.5 Safari/537.36"
   .send
    Debug.Print .Status; .statusText; " GET период для выгрузки"
   'Debug.Print XMLHTTP.getAllResponseHeaders()
   
   dlina = Len(XMLHTTP.responseText)
   txt = Right(XMLHTTP.responseText, dlina - 9)
   dlina = Len(txt)
   
   Txt0 = Left(txt, dlina - 2) & "/content/" '/content/
   
   Txt1 = Left(txt, dlina - 2) & "/content"
   txt = Left(txt, dlina - 2) & "/status"
   
   URL = "https://fos.smedservice.ru/efrapi/insurance-service/v2/contracts/extract/" & txt
    .Open "GET", URL, False
   .setRequestHeader "Cookie", Cookie1
   .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/86.0.4240.77 YaBrowser/20.11.0.821 Yowser/2.5 Safari/537.36"
   .send
    Debug.Print .Status; .statusText; " GET Формирование файла"
    Debug.Print .responseText
    
   
Do

URL = "https://fos.smedservice.ru/efrapi/insurance-service/v2/contracts/extract/" & txt
    .Open "GET", URL, False
   .setRequestHeader "Cookie", Cookie1
   .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/86.0.4240.77 YaBrowser/20.11.0.821 Yowser/2.5 Safari/537.36"
   .send
    Debug.Print .Status; .statusText; " GET Формирование файла"
    Debug.Print .responseText
    
    Application.Wait (Now + TimeValue("0:00:04"))
    'status1 = MsgBox("Продолжаем?", vbYesNo)
    
        'If status1 = 7 Then
        '   Exit Do
        'End If
    
Loop While .responseText = "{""status"":""CREATING""}"

    Debug.Print .responseText
    
URL = "https://fos.smedservice.ru/efrapi/insurance-service/v2/contracts/extract/" & Txt1
    .Open "GET", URL, False
   .setRequestHeader "Cookie", Cookie1
   .setRequestHeader "Content-Type", "application/octet-stream"
   .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/86.0.4240.77 YaBrowser/20.11.0.821 Yowser/2.5 Safari/537.36"
   .send
      
   
    Debug.Print .Status; .statusText; " GET content"
    
   End With
    
'Получаем имя файла с расширение "Отчёт по продажам с 2021-02-06 по 2021-02-06.xlsx"
FileName = CreateObject("Scripting.FileSystemObject").GetFileName(URL) & ".xlsx"


    If XMLHTTP.Status = 200 Then
        Set ADOStream = CreateObject("ADODB.Stream")
        ADOStream.Type = 1 'указываем тип данных, содержащихся в потоке. Бинарный.
        ADOStream.Open 'Открывает поток для работы потоков двоичных или текстовых данных
        ADOStream.Write XMLHTTP.responseBody 'Записываем в виде массива байтов. Используется при закачке бинарного файла
        ADOStream.SaveToFile FolderSave & FileName, 2 'Сохраняем файл в указанную папку
                                                                '1 не перезаписывать файл
                                                                '2 перезаписать файл
                                                
        ADOStream.Close 'Закрывает открытый объект и все зависимые объекты
        Set ADOStream = Nothing
        MsgBox "Файл загружен", vbInformation, "Ок"
    Else
        MsgBox "Не удаётся скачать файл", vbExclamation, "Опаньки"
End If
Set XMLHTTP = Nothing

End Sub