Здравствуйте! Просьба помочь в следующем вопросе: я загружаю на сервер через VBA некоторую информацию. После обработки макроса мне выдает сообщение об успешности запроса:
Код
MsgBox .Status
В результате мне приходит обычно успешная обработка запроса: 200.
Можно ли как-то отправить этот ответ на почту? Как отправлять письма через VBA я знаю, нашел на форуме и применял неоднократно. Но с запросом не получилось.
И тоже самое до ответа на запрос мне приходит информация от сервера в виде ключа:
Код
MsgBox (.responseText)
Как отправить письма вместо MsgBox? Либо хотя бы одного письма со статусом 200?
Ігор Гончаренко , спасибо за Вашу заботу, но я написал выше, что с запросом не получилось.Я прописывал .Status к .Body - не сработало. Как корректно прописать ответ сервера я не знаю.
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
а почитать мое сообщение вдумчиво? Я там черным по белому указал, как надо обратиться к .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
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...