Страницы: 1
RSS
Отправка письма вместо MsgBox об успешном запросе HTTP (код 200)
 
Здравствуйте!
Просьба помочь в следующем вопросе: я загружаю на сервер через VBA некоторую информацию. После обработки макроса мне выдает сообщение об успешности запроса:
Код
MsgBox .Status
В результате мне приходит обычно успешная обработка запроса: 200.

Можно ли как-то отправить этот ответ на почту? Как отправлять письма через VBA я знаю, нашел на форуме и применял неоднократно. Но с запросом не получилось.

И тоже самое до ответа на запрос мне приходит информация от сервера в виде ключа:
Код
MsgBox (.responseText)
Как отправить письма вместо MsgBox? Либо хотя бы одного письма со статусом 200?

Спасибо.
 
Цитата
написал:
Как отправлять письма через VBA я знаю,  нашел  на форуме и применял неоднократно
применяли, так примените еще раз
в чем проблема?
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко , спасибо за Вашу заботу, но я написал выше, что с запросом не получилось.Я прописывал .Status к .Body - не сработало. Как корректно прописать ответ сервера я не знаю.
Изменено: stevie44 - 06.12.2021 14:37:58
 
stevie44, ответ Игоря логичен ибо
Цитата
stevie44 написал:
 нашел  на форуме и применял неоднократно.
означает что отправлять у вас получается. А заменить надо там всего ничего
Код
With OutMail
        .To = Range("G2").Value ' адрес (кому)
        .Subject = Range("H2").Value 'Тема письма 
       .Body = .responseText 'текст сообщения . 
        ' .Attachments.Add Range("I2").Value ' путь к файлу   и  это ненужно
        'команду Send можно заменить на Display, чтобы посмотреть сообщение перед отправкой  
        .Send
    End With
По вопросам из тем форума, личку не читаю.
 
БМВ, ошибка будет. Недосмотрел немного. К чему будет относится .responseText? К With OutMail? :)
Где-то в самом начале должен быть объект oHttp(или что-то вроде), от которого мы и берем responseText. Тогда код будет примерно таким:
Код
With OutMail
        .To = Range("G2").Value ' адрес (кому)
        .Subject = Range("H2").Value 'Тема письма 
       .Body = oHttp.responseText 'текст сообщения . 
        ' .Attachments.Add Range("I2").Value ' путь к файлу   и  это ненужно
        'команду Send можно заменить на Display, чтобы посмотреть сообщение перед отправкой  
        .Send
    End With

stevie44, Вы бы прикладывали коды, с которыми не получается сладить, чтобы за Вас тут никто ничего не додумывал. Откуда мы знаем у какого объекты Вы там статусы опрашиваете...
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
,

попробовал, не выходит...
Код
Public Sub httpclient()

    Dim token As String * 1024
    token = GetToken()
    SendFile "\\...\...xlsx", token
       
End Sub
Private Function GetToken() As String

Application.DisplayAlerts = False

    Const tokenUrl As String = "https://.../authenticate"
    Const userName As String = "Name1"
    Dim userPwd As String
    userPwd = InputBox("Укажите пароль:")

    Dim tokenRequest As String
    tokenRequest = "{""username"": """ & userName & """, ""password"": """ & userPwd & """}"
    
    With CreateObject("MSXML2.ServerXMLHTTP")
        .Open "POST", tokenUrl, False
        .setRequestHeader "Content-Type", "application/json"
        .setRequestHeader "accept", "application/json"
        .send (tokenRequest)
'        MsgBox (.responseText)

'<<<<<<<<<<<<<< Формируем ответ в Outlook >>>>>>>>>>>>>>
' -----------------------------------------------------------------------------------------------------------------------
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
     
    Set OutApp = CreateObject("Outlook.Application")   'запускаем Outlook в скрытом режиме
    OutApp.Session.Logon
    On Error GoTo cleanup  'если не запустился - выходим
    Set OutMail = OutApp.CreateItem(0)   'создаем новое сообщение
    On Error Resume Next
    'заполняем поля сообщения
    With OutMail
        .To = Range("A1").value 'адрес сообщения (Кому:)
        .Subject = Range("A2").value 'тема сообщения
        .Body = .responseText
'       Set .SendUsingAccount = .Session.Accounts.Item("Hotmail") ' отправка с другой учетной записи Outlook, если их несколько, при этом Hotmail - Hotmail - название требуемой учетной записи
        .send 'просмотр сообщения перед отправкой. Без просмотра - .Send
        GetToken = Mid(.responseText, 11, Len(.responseText) - 12)
    End With
 
    On Error GoTo 0
    Set OutMail = Nothing
 
cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True ' открыть работу макроса

'----------------------------------------------
    End With
End Function


Private Sub SendFile(FileName As String, accessToken As String)

Application.DisplayAlerts = False

    Const fileType As String = "application/vnd.ms-excel"
    Const uploadUrl As String = "https://.../upload"
    Const Boundary = "---------------------------0123456789012"
    Const FieldName As String = "file"
    
    Dim FileContents, FormData
    
    FileContents = GetFile(FileName)
    FormData = BuildFormData(FileContents, Boundary, FileName, FieldName)
    With CreateObject("MSXML2.ServerXMLHTTP")
        .Open "POST", uploadUrl, False
        .setRequestHeader "Authorization", "Bearer " & accessToken
        .setRequestHeader "Content-Type", "multipart/form-data; boundary=" & Boundary
        .send (FormData)
'        MsgBox .Status
    End With
    
End Sub


Function GetFile(FileName As String)
  Dim Stream: Set Stream = CreateObject("ADODB.Stream")
  Stream.Type = 1 'Binary
  Stream.Open
  Stream.LoadFromFile FileName
  GetFile = Stream.Read
  Stream.Close
End Function


Function mpFields(FieldName, FileName, ContentType)
  Dim MPTemplate
  MPTemplate = "Content-Disposition: form-data; name=""{field}"";" + _
   " filename=""{file}""" + vbCrLf + _
   "Content-Type: {ct}" + vbCrLf + vbCrLf
  Dim Out
  Out = Replace(MPTemplate, "{field}", FieldName)
  Out = Replace(Out, "{file}", FileName)
  mpFields = Replace(Out, "{ct}", ContentType)
End Function


Function StringToMB(S)
  Dim i, B
  For i = 1 To Len(S)
    B = B & ChrB(Asc(Mid(S, i, 1)))
  Next
  StringToMB = B
End Function


Function BuildFormData(FileContents, Boundary, FileName, FieldName)
  Dim FormData, Pre, Po
  Const ContentType = "application/upload"
  
  Pre = "--" + Boundary + vbCrLf + mpFields(FieldName, FileName, ContentType)
  Po = vbCrLf + "--" + Boundary + "--" + vbCrLf
  
  Const adLongVarBinary = 205
  Dim RS: Set RS = CreateObject("ADODB.Recordset")
  RS.Fields.Append "b", adLongVarBinary, Len(Pre) + LenB(FileContents) + Len(Po)
  RS.Open
  RS.AddNew
    Dim LenData
    LenData = Len(Pre)
    RS("b").AppendChunk (StringToMB(Pre) & ChrB(0))
    Pre = RS("b").GetChunk(LenData)
    RS("b") = ""
    LenData = Len(Po)
    RS("b").AppendChunk (StringToMB(Po) & ChrB(0))
    Po = RS("b").GetChunk(LenData)
    RS("b") = ""
    RS("b").AppendChunk (Pre)
    RS("b").AppendChunk (FileContents)
    RS("b").AppendChunk (Po)
  RS.Update
  FormData = RS("b")
  RS.Close
  BuildFormData = FormData
End Function

 
Цитата
stevie44 написал:
попробовал,
а почитать мое сообщение вдумчиво? Я там черным по белому указал, как надо обратиться к .responseText.
Вам надо определиться - либо использовать With CreateObject("MSXML2.ServerXMLHTTP"), либо With OutMail. Нельзя обратиться через With к двум совершенно не связанным объектам - такое возможно только в пределах "иерархии". Т.е. только если один из объектов является объектом другого.
В Вашем случае проще всего сделать так:
Код
Private Function GetToken() As String
 
Application.DisplayAlerts = False
 
    Const tokenUrl As String = "https://.../authenticate"
    Const userName As String = "Name1"
    Dim userPwd As String
    userPwd = InputBox("Укажите пароль:")
 
    Dim tokenRequest As String
    tokenRequest = "{""username"": """ & userName & """, ""password"": """ & userPwd & """}"
    
    dim sResTxt$ 'переменная для хранения ответа responseText
    With CreateObject("MSXML2.ServerXMLHTTP")
        .Open "POST", tokenUrl, False
        .setRequestHeader "Content-Type", "application/json"
        .setRequestHeader "accept", "application/json"
        .send (tokenRequest)
        sResTxt = .responseText 'запоминаем в переменную полученный ответ
    End With
'<<<<<<<<<<<<<< Формируем ответ в Outlook >>>>>>>>>>>>>>
' -----------------------------------------------------------------------------------------------------------------------
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
      
    Set OutApp = CreateObject("Outlook.Application")   'запускаем Outlook в скрытом режиме
    OutApp.Session.Logon
    On Error GoTo cleanup  'если не запустился - выходим
    Set OutMail = OutApp.CreateItem(0)   'создаем новое сообщение
    On Error Resume Next
    'заполняем поля сообщения
    With OutMail
        .To = Range("A1").value 'адрес сообщения (Кому:)
        .Subject = Range("A2").value 'тема сообщения
        .Body = sResTxt 'используем переменную sResTxt для отправки текста ответа в письме
'       Set .SendUsingAccount = .Session.Accounts.Item("Hotmail") ' отправка с другой учетной записи Outlook, если их несколько, при этом Hotmail - Hotmail - название требуемой учетной записи
        .send 'просмотр сообщения перед отправкой. Без просмотра - .Send
        GetToken = Mid(sResTxt, 11, Len(sResTxt) - 12)
    End With
  
    On Error GoTo 0
    Set OutMail = Nothing
  
cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True ' открыть работу макроса
 
'----------------------------------------------
    
End Function
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Страницы: 1
Наверх