Checking out https://wqweto.wordpress.com/2011/07/12/vb6-using-wininet-to-post-binary-file/ I get it how to upload a file, but I still need to add some additional parameters along the request, namely, _ID where this file should be put on server.
Currently I'm using code from first link:
Const STR_BOUNDARY As String = "3fbd04f5-b1ed-4060-99b9-fca7ff59c113"
Dim nFile As Integer
Dim baBuffer() As Byte
Dim sPostData As String
Dim pvPostFile As String
'--- read file
nFile = FreeFile
Open strPathFile For Binary Access Read As nFile
If LOF(nFile) > 0 Then
ReDim baBuffer(0 To LOF(nFile) - 1) As Byte
Get nFile, , baBuffer
sPostData = StrConv(baBuffer, vbUnicode)
End If
Close nFile
'--- prepare body
sPostData = "--" & STR_BOUNDARY & vbCrLf & _
"Content-Disposition: form-data; name=""uploadfile""; filename=""a.xls""" & vbCrLf & _
"Content-Type: application/octet-stream" & vbCrLf & vbCrLf & _
sPostData & vbCrLf & _
"--" & STR_BOUNDARY & "--" & _
"--" & STR_BOUNDARY & vbCrLf & _
"Content-Disposition: form-data; name=""_id"";" & vbCrLf & vbCrLf & _
"BFKrhMovy25DDemGE" & _
"--" & STR_BOUNDARY & "--"
'--- post
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "POST", "https://api.backend.org/api/v1/upload/", False
.SetRequestHeader "Authorization: Bearer FbKl4KmuSdiXlk6PsWbvs9"
.SetRequestHeader "Content-Type: multipart/form-data; boundary=" & STR_BOUNDARY
.Send pvToByteArray(sPostData)
pvPostFile = .ResponseText
End With
MsgBox pvPostFile
Private Function pvToByteArray(sText As String) As Byte()
pvToByteArray = StrConv(sText, vbFromUnicode)
End Function
I'm getting "Named argument not found" in section
With CreateObject("WinHttp.WinHttpRequest.5.1")
not sure how to debug this :(
I have checked reference to Microsoft WinHTTP Services, version 5.1.
EDIT:
Problem was in SetRequestHeader, it needs two parameters following.
So correct code for SetRequestHeader lines is:
.SetRequestHeader "Authorization", "Bearer FbKl4KmuSdiXlk6PsWbvs9"
.SetRequestHeader "Content-Type", "multipart/form-data; boundary=" & STR_BOUNDARY
Main problem for me was understanding how parameters work in VBA, coming from total PHP environment..
So correctly setting .SetRequestHeader parameters and correctly putting together custom parameter with using two vbCrLf made all the difference.
With this solution, you can send as many params as you want now..
Related
I want to upload a photo from my local machine (e.g. a jpg) to a Facebook page I am the admin on, using the Facebook Graph API (using Access VBA).
I can post an image that is on the internet already to the Facebook page, with a message, that works fine.
But I want the file to come from my local machine...
I can't work it out!
This code (VBA) works to upload a JPG that is already on the internet
Dim httpRequest As Object
Dim boundary As String
Dim postData As String
Dim pageID As String, accessToken As String, fileUrl As String, message As String
pageID = "[My Page ID]"
accessToken = "[My long-lived Access Token]"
fileUrl = "https://www.facebook.com/images/fb_icon_325x325.png"
message = "test message"
boundary = "----------------------------" & Format(Now, "ddmmyyyyhhmmss")
postData = "--" & boundary & vbCrLf & _
"Content-Disposition: form-data; name=""message""" & vbCrLf & _
"Content-Type: text/plain; charset=UTF-8" & vbCrLf & vbCrLf & _
message & vbCrLf & _
"--" & boundary & vbCrLf & _
"Content-Disposition: form-data; name=""url""" & vbCrLf & _
"Content-Type: text/plain; charset=UTF-8" & vbCrLf & vbCrLf & _
fileUrl & vbCrLf & _
"--" & boundary & "--"
Set httpRequest = CreateObject("MSXML2.XMLHTTP")
With httpRequest
.Open "POST", "https://graph.facebook.com/" & pageID & "/photos?access_token=" & accessToken, False
.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & boundary
.send (postData)
If .status = 200 Then
Debug.Print .responseText
Else
Debug.Print "Error: " & .status & " - " & .statusText
End If
End With
This works.
I can't for the life of me work out how to change the photo to be one from my local machine though.
Please note: I have the correct token settings because, as I say, this code above works for a photo that is already on the internet - so my page ID and my access token must be correct.
[My text logical question will be.... how do I upload multiple photos?]
Thanks for any help you can offer!
A URL like this should work:
file:///C:/Test/YourImage.jpg
Note the forward slashes, though you may get away with backslashes in the filename part.
OK I managed to get this working:
Public Function UploadFileToFacebookPage()
Dim httpRequest As Object
Dim boundary As String
Dim postData As String
Dim pageID As String, accessToken As String, fileUrl As String, message As String
pageID = "[My page ID]"
accessToken = "[My long-lived access token]"
Dim fileName As String, filePath As String
filePath = "Z:\Desktop\testimage.jpg"
fileName = "testimage.jpg"
message = "test message"
boundary = "----------------------------" & Format(Now, "ddmmyyyyhhmmss")
postData = "--" & boundary & vbCrLf
postData = postData & "Content-Disposition: form-data; name=""message""" & vbCrLf
postData = postData & "Content-Type: text/plain; charset=UTF-8" & vbCrLf & vbCrLf
postData = postData & message & vbCrLf
postData = postData & "--" & boundary & vbCrLf
postData = postData & "Content-Disposition: form-data; name=""source""; filename=""" & fileName & """" & vbCrLf
postData = postData & "Content-Type: image/jpeg" & vbCrLf & vbCrLf
postData = postData & getBinaryFile(filePath) & vbCrLf
postData = postData & "--" & boundary & "--" & vbCrLf
Set httpRequest = CreateObject("MSXML2.XMLHTTP")
With httpRequest
.Open "POST", "https://graph.facebook.com/" & pageID & "/photos?access_token=" & accessToken, False
.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & boundary
.send ToByteArray(postData) ' Convert from Unicode
If .Status = 200 Then
Debug.Print .ResponseText
Else
Debug.Print "Error: " & .Status & " - " & .statusText
End If
End With
End Function
and
Function getBinaryFile(filePath) As Variant
Dim binaryStream As Variant
Set binaryStream = CreateObject("ADODB.Stream")
binaryStream.Type = 1
binaryStream.Open
binaryStream.LoadFromFile filePath
getBinaryFile = StrConv(binaryStream.Read, vbUnicode) ' Convert to Unicode
binaryStream.Close
End Function
and
Function ToByteArray(str As String) As Byte()
ToByteArray = StrConv(str, vbFromUnicode)
End Function
i have a function to upload multipart/form-data with Visual Basic 6 using MSXML2.ServerXMLHTTP60, no problem with 100MB file size, but when i upload 200MB it's show "Run Time Error '7'" Out Of Memory.
this is my code:
Public Function PostFile(sUrl As String, sJSON As String, sFileName As String) As String
Const STR_BOUNDARY As String = "864d391d-4097-44e0-92e1-71aff17094c1"
Dim sPostData As String
Dim bytData
With CreateObject("ADODB.Stream")
.Type = 1
.Mode = 3
.Open
.LoadFromFile sFileName
bytData = .Read
End With
With CreateObject("ADODB.Stream")
.Mode = 3
.Charset = "Windows-1252"
.Open
.Type = 2
.WriteText "--" & STR_BOUNDARY & vbCrLf
.WriteText "Content-Disposition: form-data; name=""json""" & vbCrLf
.WriteText "Content-Type: application/json" & vbCrLf & vbCrLf
.WriteText sJSON & vbCrLf
.WriteText "--" & STR_BOUNDARY & vbCrLf
.WriteText "Content-Disposition: form-data; name=""uploadfile""; filename=""" & Mid$(sFileName, InStrRev(sFileName, "\") + 1) & """" & vbCrLf
.WriteText "Content-Type: application/octet-stream" & vbCrLf & vbCrLf
.Position = 0
.Type = 1
.Position = .Size
.Write bytData
.Position = 0
.Type = 2
.Position = .Size
.WriteText vbCrLf & "--" & STR_BOUNDARY & "--"
.Position = 0
.Type = 1
sPostData = StrConv(.Read, vbUnicode)
End With
With New MSXML2.ServerXMLHTTP60
.Open "POST", sUrl, True
.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & STR_BOUNDARY
.send ToByteArray(sPostData)
.waitForResponse 300 'second
If .Status = 200 Then PostFile = .responseText Else .abort
End With
End Function
Private Function ToByteArray(sText As String) As Byte()
ToByteArray = StrConv(sText, vbFromUnicode)
End Function
Before i update the script above i using "open file method" to read binary file like below:
Public Function PostFile(sUrl As String, sJSON As String, sFileName As String) As String
Const STR_BOUNDARY As String = "864d391d-4097-44e0-92e1-71aff17094c1"
Dim nFile As Integer
Dim baBuffer() As Byte
Dim sPostData As String
nFile = FreeFile
Open sFileName For Binary Access Read As nFile
If LOF(nFile) > 0 Then
ReDim baBuffer(0 To LOF(nFile) - 1) As Byte
Get nFile, , baBuffer
sPostData = StrConv(baBuffer, vbUnicode)
End If
Close nFile
'--- prepare body
sPostData = "--" & STR_BOUNDARY & vbCrLf & _
"Content-Disposition: form-data; name=""json""" & vbCrLf & _
"Content-Type: application/json" & vbCrLf & vbCrLf & _
sJSON & vbCrLf & _
"--" & STR_BOUNDARY & vbCrLf & _
"Content-Disposition: form-data; name=""uploadfile""; filename=""" & Mid$(sFileName, InStrRev(sFileName, "\") + 1) & """" & vbCrLf & _
"Content-Type: application/octet-stream" & vbCrLf & vbCrLf & _
sPostData & vbCrLf & _
"--" & STR_BOUNDARY & "--"
'--- post
With New MSXML2.ServerXMLHTTP60
.Open "POST", sUrl, True
.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & STR_BOUNDARY
.send ToByteArray(sPostData)
.waitForResponse 300 'second
If .Status = 200 Then PostFile = .responseText Else .abort
End With
End Function
Private Function ToByteArray(sText As String) As Byte()
ToByteArray = StrConv(sText, vbFromUnicode)
End Function
But, that show error "Run Time Error '14'" Out of string space
how to handle this error?
I'm trying to send PDF file using MSXML2.xmlhttp but the client receive empty PDF File as an attachment without any errors. I'm using Visual Basic 6.0 to send requests.
I sent the same file with RingCentral Web App and it works. I think the binary conversion is not working properly. Here is my code:
Function CreateFaxMessage(strPath, _
strStatus, _
Receiver, _
Optional coverPageText = "", _
Optional strResponse = "", _
Optional faxResolution As String = "High") As Boolean
Dim strFile, strExt, strContentType, strBoundary, bytData, bytPayLoad
On Error Resume Next
104 With CreateObject("Scripting.FileSystemObject")
106 If .FileExists(strPath) Then
108 strFile = .GetFileName(strPath)
110 strExt = .GetExtensionName(strPath)
Else
112 strStatus = "File not found"
114 CreateFaxMessage = False
Exit Function
End If
End With
116 With CreateObject("Scripting.Dictionary")
146 .Add "pdf", "application/pdf"
148 strContentType = .Item(LCase(strExt))
End With
150 If strContentType = "" Then
152 strStatus = "Invalid file type"
154 CreateFaxMessage = False
Exit Function
End If
174 strBoundary = String(2, "-") & Replace(Mid(CreateObject("Scriptlet.TypeLib").Guid, 2, 36), "-", "")
Dim nFile As Integer
Dim baBuffer() As Byte
Dim sPostData As String
'--- read file
nFile = FreeFile
Open strPath For Binary Access Read As nFile
If LOF(nFile) > 0 Then
ReDim baBuffer(0 To LOF(nFile) - 1) As Byte
Get nFile, , baBuffer
sPostData = StrConv(baBuffer, vbFromUnicode)
End If
Close nFile
'--- prepare body
sPostData = strBoundary & vbCrLf & _
"Content-Disposition: form-data; name=""attachment""; filename=""" & strFile & """" & vbCrLf & _
"Content-Transfer-Encoding: binary" & vbCrLf & _
"Content-Type: " & strContentType & vbCrLf & vbCrLf & _
sPostData & vbCrLf
sPostData = sPostData & strBoundary & "--"
Dim params As String
220 params = strBoundary & vbCrLf
222 params = params & "Content-Disposition: form-data; name=""faxResolution""" & vbCrLf & vbCrLf
224 params = params & faxResolution & vbCrLf
232 params = params & strBoundary & vbCrLf
params = params & "Content-Disposition: form-data; name=""to""" & vbCrLf & vbCrLf
params = params & Receiver & vbCrLf
Dim XMLHTTP As Object
218 Set XMLHTTP = CreateObject("MSXML2.ServerXMLHTTP")
240 With XMLHTTP
242 .setTimeouts 0, 60000, 300000, 300000
244 .Open "POST", FaxURL, False
246 '.setRequestHeader "Accept", "application/json; boundary=" & strBoundary
248 .setRequestHeader "Content-Type", "multipart/form-data; boundary=" & Mid(strBoundary, 3)
250 .setRequestHeader "Authorization", "Bearer " & RingCentral.AccessToken
252 .send params & sPostData
260 If Ok(.status) Then
262 strResponse = .responseText
264 CreateFaxMessage = True
Else
266 MsgBox .statusText & " (" & .status & ")"
End If
End With
Exit Function
End Function
I am attempting to submit a file on a HTTPS site using VBA, but I am having issues with the authentication. (When viewed, the site has the standard field for file name, with a "browse" button, and a "submit" button.)
I've tried a couple of things... first, I used an InternetExplorer.Application object, but the element type that I need to populate is file, and I've read that this is not directly accessible via code for security reasons. (Sorry I don't have the link for a citation...)
Next suggestion was to use a WinHttp.WinHttpRequest.5.1 object and a PUT request. When I do that however, the response from the site is a 401, invalid authentication error.
I'm able to access the site without entering any credentials when I'm browsing normally. I've looked at some questions about HTTPS headers here and here, but haven't been able to get them to work. Can anyone see what I'm doing wrong?
Dim objHTTP As Object
Dim URL As String
Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
URL = "https://siteImUploadingTo.domain.com/site"
objHTTP.Open "PUT", URL, False
objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.setRequestHeader "Content-type", "application/x-www-form-urlencoded"
objHTTP.Send ("_fileToPost=" & ThisWorkbook.Path & \filename.PDF&_pagesSelection=1-100")
Debug.Print objHTTP.ResponseText 'returns a 401 invalid credentials error.
Looking at your code, it appears that you're missing a .SetCredentials call, after .Open and before .Send:
objHTTP.SetCredentials username, password, HTTPREQUEST_SETCREDENTIALS_FOR_SERVER
I ran your code on my test environment, and I also had to set the WinHttpRequestOption_SslErrorIgnoreFlags option to be able to ignore all SSL errors (reference):
objHTTP.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = &H3300 //SslErrorFlag_Ignore_All
At last, I don't think your Send command will work at actually posting a file to your server. I recommend you using the code below, adapted from this blog post.
' add a reference to "Microsoft WinHTTP Services, version 5.1"
Public Function PostFile( _
sUrl As String, sFileName As String, sUsername As String, sPassword As String, _
Optional bIgnoreAllSslErrors As Boolean = False, Optional bAsync As Boolean _
) As String
Const HTTPREQUEST_SETCREDENTIALS_FOR_SERVER = 0
Const STR_BOUNDARY As String = "3fbd04f5-b1ed-4060-99b9-fca7ff59c113"
Dim nFile As Integer
Dim baBuffer() As Byte
Dim sPostData As String
Dim browser As WinHttp.WinHttpRequest
'--- read file
nFile = FreeFile
Open sFileName For Binary Access Read As nFile
If LOF(nFile) > 0 Then
ReDim baBuffer(0 To LOF(nFile) - 1) As Byte
Get nFile, , baBuffer
sPostData = StrConv(baBuffer, vbUnicode)
End If
Close nFile
'--- prepare body
sPostData = _
"--" & STR_BOUNDARY & vbCrLf & _
"Content-Disposition: form-data; name=""uploadfile""; filename=""" & Mid$(sFileName, InStrRev(sFileName, "\") + 1) & """" & vbCrLf & _
"Content-Type: application/octet-stream" & vbCrLf & vbCrLf & _
sPostData & vbCrLf & _
"--" & STR_BOUNDARY & "--"
'--- post
Set browser = New WinHttpRequest
browser.Open "POST", sUrl, bAsync
browser.SetCredentials sUsername, sPassword, HTTPREQUEST_SETCREDENTIALS_FOR_SERVER
If bIgnoreAllSslErrors Then
' https://stackoverflow.com/questions/12080824/how-to-ignore-invalid-certificates-with-iwinhttprequest#12081003
browser.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = &H3300
End If
browser.SetRequestHeader "Content-Type", "multipart/form-data; boundary=" & STR_BOUNDARY
browser.Send pvToByteArray(sPostData)
If Not bAsync Then
PostFile = browser.ResponseText
End If
End Function
Private Function pvToByteArray(sText As String) As Byte()
pvToByteArray = StrConv(sText, vbFromUnicode)
End Function
If you need to send additional fields, you can do so by modifying the sPostData variable:
sPostData = _
"--" & STR_BOUNDARY & vbCrLf & _
"Content-Disposition: form-data; name=""field1""" & vbCrLf & vbCrLf & _
field1 & vbCrLf & _
"--" & STR_BOUNDARY & vbCrLf & _
"Content-Disposition: form-data; name=""field2""" & vbCrLf & vbCrLf & _
field2 & vbCrLf & _
"--" & STR_BOUNDARY & vbCrLf & _
"Content-Disposition: form-data; name=""uploadfile""; filename=""" & Mid$(FileFullPath, InStrRev(FileFullPath, "\") + 1) & """" & vbCrLf & _
"Content-Type: application/octet-stream" & vbCrLf & vbCrLf & _
sPostData & vbCrLf & _
"--" & STR_BOUNDARY & "--"
I need help getting this code to work. I'm completely new at programming in VBA as well as anything related to HTTP Post and forms. I've tried to do everything to make it work by reading questions here and following the API help but nothing seems to work.
Here is the website where you can find the API Reference:
http://service.ringcentral.com/faxoutapi/
Also here is the code I have so far:
Sub POST()
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
Dim strURL As String
Dim PostData As String
strURL = "https://service.ringcentral.com/faxapi.asp"
Const Boundary As String = "---------------------------7d54b1fee05aa"
WinHttpReq.Open "POST", strURL, False
WinHttpReq.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & Boundary
PostData = "--" & Boundary & vbCrLf
PostData = PostData & "Content-Disposition: form-data; name=""Username""" & vbCrLf
PostData = PostData & "username" & vbCrLf
PostData = PostData & "--" & Boundary & vbCrLf
PostData = PostData & "Content-Disposition: form-data; name=""Password""" & vbCrLf
PostData = PostData & "password" & vbCrLf
PostData = PostData & "--" & Boundary & vbCrLf
PostData = PostData & "Content-Disposition: form-data; name=""Recipient""" & vbCrLf
PostData = PostData & "faxnumber" & vbCrLf
PostData = PostData & "--" & Boundary & vbCrLf
PostData = PostData & "Content-Disposition: form-data; name=""Coverpagetext""" & vbCrLf
PostData = PostData & "This is a test fax from web" & vbCrLf
PostData = PostData & "--" & Boundary & vbCrLf
WinHttpReq.Send (PostData)
MsgBox WinHttpReq.ResponseText
End Sub
I keep getting a response value of 5 which means a generic error. I'm pretty sure the form doesn't match the correct format. I would also like to be able to upload a file as shown in the API's reference.
Thanks in advance
The FaxOut.asp API endpoint was end-of-lifed on August 9 2018.
See more in the noticed here:
https://support.ringcentral.com/article/Legacy-API-End-of-Life-Announcement-RingOut-asp-FaxOut-asp.html
Use the new endpoint at:
https://platform.devtest.ringcentral.com/restapi/v1.0/account/{accountId}/extension/{extensionId}/fax
https://developers.ringcentral.com/api-reference/Fax/createFaxMessage