CSV string from GET request incomplete when storing in variable - vba

In VBA, I currently have code that returns a CSV string from the internet. However, it seems like the entire file is not being captured when I try to store it in a string variable using .responseText
I've heard string sizes are limited, which makes this problem understandable (I'm trying to store 1000 rows of data into a variable - which is probably not possible). I was wondering if there is a way to download the CSV file straight from the source given that I have the URL to get the response? Here is the relevant code that I have:
Dim JiraReq As New MSXML2.XMLHTTP60
With JiraReq
' Create Session
downloadUrl = https://myurlishere.atlassian.net
' This is not the actual form of the URL, but it does
' successfully grab the CSV string (but the string variable
' will not store all of it - probably because of the size)
.Open "GET", downloadUrl, False
.setRequestHeader "Authorization", "Basic " + EncodeBase64(username + ":" + password)
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.send
End With
CSVData = JiraReq.responseText
If JiraReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write JiraReq.responseText
Filename = "C:\file" & i & ".csv"
oStream.SaveToFile Filename, 2
oStream.Close
End If
For reference, I have looked at the following links to try to solve this issue:
Arguments out of acceptable range
Downloading file from web with VBA
HTTP response text returning incomplete Data

My code ended up looking like this:
For i = 1 To pageCount Step 1
' MsgBox "Entering For Loop"
Dim startNumber As Integer
startNumber = (i - 1) * 1000
Dim downloadUrl As String
downloadUrl = "https://myurl.atlassian.net/sr/jira.issueviews:searchrequest-csv-current-fields/" & CStr(filterID) & "/SearchRequest-" & CStr(filterID) & ".csv?tempMax=1000&pager/start=" & CStr(startNumber)
With JiraReq
' Create Session
Debug.Print "Getting page " & CStr(i) & " of " & CStr(pageCount)
.Open "GET", downloadUrl, False
.setRequestHeader "Authorization", "Basic " + EncodeBase64(username + ":" + password)
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.send
End With
file_name = "C:\VBA\file" & i & ".csv"
If JiraReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write JiraReq.responseBody
oStream.SaveToFile file_name, 2 ' 1 = no overwrite, 2 = overwrite
oStream.Close
End If
I had to change from .responseText to .responseBody.

Related

VBA PDF File Upload Using HTTP POST

I'm trying to upload a file to a .NET Core API using VBA code from a Word template. When the API receives the request, the file has a length of 0 and therefore any file I send to it becomes useless. I've uploaded files successfully to the same API using an Angular client instead of VBA, so I believe the problem lies within my VBA code. I've tested it with both .txt and .pdf files and the result is the same, 0 length file is received in the API (the end goal is to be able to upload a PDF file).
Do you see what's wrong with the code I'm using? Please see below. Any help is greatly appreciated.
Sub UploadBinary()
Const path = "C:\Users\REDACTED\VBA Upload Test\"
Const fileName = "testfile.txt"
Const CONTENT = "text/plain"
Const URL = "https://localhost:44327/api/fileUpload"
' generate boundary
Dim BOUNDARY, s As String, n As Integer
For n = 1 To 16: s = s & Chr(65 + Int(Rnd * 25)): Next
BOUNDARY = s & CDbl(Now)
Dim part As String, ado As Object
Dim header As String
' read file
Dim FILE, FILESIZE
Set ado = CreateObject("ADODB.Stream")
ado.Type = 1 'binary
ado.Open
ado.LoadFromFile path & fileName
ado.Position = 0
FILESIZE = ado.Size
FILE = ado.Read
ado.Close
Debug.Print "filesize", FILESIZE
part = "--" & BOUNDARY & vbCrLf
part = part & "Content-Disposition: form-data; name=""file""; filename=""" & fileName & """" & vbCrLf
part = part & "Content-Type: " & CONTENT & vbCrLf
part = part & "Content-Length: " & FILESIZE & vbCrLf & vbCrLf & vbCrLf
part = part & "--" & BOUNDARY & "--" & vbCrLf
header = "Content-Type" & ": " & "multipart/form-data; boundary=" & BOUNDARY
Debug.Print (header)
Debug.Print (part)
' combine part, fl , end
ado.Open
ado.Position = 0
ado.Type = 1 ' binary
ado.Write ToBytes(part)
ado.Write FILE
ado.Write ToBytes(vbCrLf & "--" & BOUNDARY & "---")
ado.Position = 0
Debug.Print ado.Size
'ado.savetofile "c:\tmp\debug.bin", 2 ' overwrite
' send request
'With CreateObject("WinHttp.WinHttpRequest.5.1")
With CreateObject("MSXML2.ServerXMLHTTP")
.Open "POST", URL, False
.SetRequestHeader "Content-Type", "multipart/form-data; boundary=" & BOUNDARY
.Send ado.Read
ado.Close
Debug.Print .ResponseText
End With
End Sub
Function ToBytes(str As String) As Variant
Dim ado As Object
Set ado = CreateObject("ADODB.Stream")
ado.Open
ado.Type = 2 ' text
ado.Charset = "_autodetect"
ado.WriteText str
ado.Position = 0
ado.Type = 1
ToBytes = ado.Read
ado.Close
End Function
Was able to make it work this way:
Public Sub UploadFile()
'Dim sFormData As String
Dim sFormData, bFormData
Dim d As String, DestURL As String, fileName As String, FilePath As String, FieldName As String
FieldName = "File"
DestURL = "https://localhost:44327/api/fileUpload"
'FileName = "testfile.txt"
'CONTENT = "text/plain"
fileName = "filename.pdf"
CONTENT = "application/pdf"
FilePath = "C:\path" & fileName
'Boundary of fields.
'Be sure this string is Not In the source file
Const Boundary As String = "---------------------------0123456789012"
Dim File, FILESIZE
Set ado = CreateObject("ADODB.Stream")
ado.Type = 1 'binary
ado.Open
ado.LoadFromFile FilePath
ado.Position = 0
FILESIZE = ado.Size
File = ado.Read
ado.Close
Set ado = CreateObject("ADODB.Stream")
d = "--" + Boundary + vbCrLf
d = d + "Content-Disposition: form-data; name=""" + FieldName + """;"
d = d + " filename=""" + fileName + """" + vbCrLf
d = d + "Content-Type: " & CONTENT + vbCrLf + vbCrLf
ado.Type = 1 'binary
ado.Open
ado.Write ToBytes(d)
ado.Write File
ado.Write ToBytes(vbCrLf + "--" + Boundary + "--" + vbCrLf)
ado.Position = 0
With CreateObject("MSXML2.ServerXMLHTTP")
.Open "POST", DestURL, False
.SetRequestHeader "Content-Type", "multipart/form-data; boundary=" & Boundary
.Send ado.Read
Debug.Print .ResponseText
End With
End Sub
Function ToBytes(str As String) As Variant
Dim ado As Object
Set ado = CreateObject("ADODB.Stream")
ado.Open
ado.Type = 2 ' text
ado.Charset = "_autodetect"
ado.WriteText str
ado.Position = 0
ado.Type = 1
ToBytes = ado.Read
ado.Close
End Function

HTTP request (Stripe) VBA send DATA - getting error after days of working

I have created a project in Ms Access which creates customer accounts on Stripe. Credit card stuff is via elements in a secure manner.
The situation:
It is running on my test (home) environment fine.
It was running at my business for 2 days
Today I used it and am now getting:
The Connection with the server was terminated abnormally
Code:
reqBody = "description=" & desc & _
"&name=" & pName & _
"&phone=" & pPhone & _
"&address[line1=" & pAdd & _
"&address[city=" & pSuburb & _
"&address[country=AU" & _
"&address[postal_code=" & pPCode & _
"&address[state=Western Australia"
Set httpReq = CreateObject("MSXML2.ServerXMLHTTP")
httpReq.Open "POST", "https://api.stripe.com/v1/customers", False
httpReq.setRequestHeader "Authorization", "Bearer " & api_key
httpReq.send reqBody
strResponse = httpReq.responseText
Set parsed = JsonConverter.ParseJson(strResponse)
'Debug.Print strResponse
StripeCustID = parsed("id")
Now I read some other posts and tried using:
httpReq.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
and still no luck,
I ahve also tried:
Dim HTTPRequest As WinHttp.WinHttpRequest
Set HTTPRequest = New WinHttp.WinHttpRequest
With HTTPRequest
.Open "POST", "https://api.stripe.com/v1/customers", True
.setRequestHeader "Authorization", "Bearer " & api_key
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.Option(WinHttpRequestOption_SecureProtocols) = SecureProtocol_TLS1_2
'.Option(WinHttpRequestOption_EnableRedirects) = True
.send reqBody
If .waitForResponse(3) Then
strResponse = .responseText
Debug.Print .responseText
Else
MsgBox "Timed out after 3 seconds."
Exit Sub
End If
End With
But with this it is coming up as [SecureProtocol_TLS1_2] not defined (I have the reference to WinHttp)
My test environment is Windows 10, my work on is Windows 7, both are 64x.
But the fact remains, this was working for two days on the work computers and now giving me this error.

Sending local photos via VBA to Telegram

I'm trying to send a local photo using VBA or VBScript. The solutions I found are either for sending URLs instead of files, or for other than VBA or VBScript.
Sub TelegramAuto()
Dim ws As Worksheet
Set ws = Sheets("hidden")
Set ws1 = Sheets("Dashboard")
Dim objRequest As Object
Dim strChatId As String
Dim strMessage As String
Dim strPhoto As String
Dim strPostPhoto As String
Dim strPostData As String
Dim strResponse As String
strChatId = <id>
strMessage = ws.Range("J5") & Format(ws1.Range("D2"), "mm/dd/yyyy") & " " & ws1.Range("D4") & " " & ws1.Range("D6") _
& " " & ws1.Range("K6")
strPhoto = "C:/Users/mhjong/Desktop/GP_FS_Breakdown.png"
strPostData = "chat_id=" & strChatId & "&text=" & strMessage
strPostPhoto = "chat_id=" & strChatId & "&photo=" & strPhoto
Set objRequest = CreateObject("MSXML2.XMLHTTP")
With objRequest
.Open "POST", "https://api.telegram.org/bot<token>/sendMessage?", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send (strPostData)
End With
With objRequest
.Open "POST", "https://api.telegram.org/bot<token>/sendPhoto?", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.Send (strPostPhoto)
End With
End Sub
I can send messages. I cannot find the syntax to upload a local image and send it to Telegram.
strPhoto = "image link"
strPostPhoto = "chat_id=" & strChatId & "&photo=" & strPhoto
With objRequest
.Open "POST", "https://api.telegram.org/bot<Token>/sendPhoto?" & strPostPhoto, False
.send
End With
Public Function tmBotSend(Token As String, chat_id As String, Optional text As String = "", Optional filename As String = "", Optional pavd As String = "") As String
'https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=93149&TITLE_SEO=93149-kak-sdelat-otpravku-v-telegram-iz-makrosa-vba-excel&MID=1193376#message1193376
'pavd as photo animation audio voice video document
'4096 chars for message.text, 200 chars for message.caption
Const adTypeBinary = 1
Const adTypeText = 2
Const adModeReadWrite = 3
Const telegram = "https://api.telegram.org/bot"
Dim part As String
part = bond("--") & form("chat_id") & chat_id & bond()
Dim dfn As String
If Len(filename) Then dfn = Dir(filename)
Dim caption As String
Dim send As String
If Len(dfn) Then
caption = "caption"
Select Case LCase(pavd)
Case "photo", "animation", "audio", "voice", "video", "document"
send = LCase(pavd)
Case Else
dfnA = Split(LCase(dfn), ".")
Select Case dfnA(UBound(dfnA))
Case "jpg", "jpeg", "png"
send = "photo"
Case "gif", "apng"
send = "animation"
Case "mp4"
send = "video"
Case "mp3", "m4a"
send = "audio"
Case "ogg"
send = "voice"
Case Else
send = "document"
End Select
End Select
Else
caption = "text"
send = "message"
End If
part = part & form(caption) & text
Dim file
Dim body
With CreateObject("ADODB.Stream")
If Len(dfn) Then
' filename
part = part & bond() & form(send, dfn)
' read file as binary
.Mode = adModeReadWrite
.Type = adTypeBinary
.Open
.LoadFromFile filename
.Position = 0
file = .Read
.Close
End If
' combine part, file , end
.Type = adTypeBinary
.Open
.Position = 0
.Write ToBytes(part)
'Debug.Print part
If Len(dfn) Then .Write file
.Write ToBytes(bond(suff:="--"))
.Position = 0
body = .Read
.Close
End With
With CreateObject("MSXML2.XMLHTTP")
'Debug.Print telegram & Token & "/send" & StrConv(send, vbProperCase)
.Open "POST", telegram & Token & "/send" & StrConv(send, vbProperCase), False
.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & bond("", "")
.send body
tmBotSend = .responseText
'Debug.Print .responseText
End With
End Function
Function ToBytes(str As String) As Variant
Const adTypeBinary = 1
Const adTypeText = 2
Const adModeReadWrite = 3
With CreateObject("ADODB.Stream")
.Mode = adModeReadWrite
.Type = adTypeText
.Charset = "UTF-8" '"_autodetect"
.Open
.WriteText str
.Position = 0
.Type = adTypeBinary
ToBytes = .Read
.Close
End With
End Function
Private Function bond(Optional pref As String = vbCrLf & "--", Optional suff As String = vbCrLf, Optional BOUNDARY As String = "--OYWFRYGNCYQAOCCT44655,4239930556") As String
bond = pref & BOUNDARY & suff
End Function
Private Function form(ByVal name As String, Optional ByVal filename As String = "") As String
form = "Content-Disposition: form-data; name=""" & name & """"
If Len(filename) Then form = form & "; filename=""" & filename & """"
form = form & vbCrLf & vbCrLf
End Function

VBA HTTP Request POST returning empty string

I am working on a procedure, in MS-Access VBA, to POST an XML text string to a web service and process the XML text string that is returned from the service.
The issue I am having is that the responseText property is always empty when it should contain a XML text string. No errors are returned and the .status = "OK".
I have tried the WinHttp.WinHttpRequest, MSXML2.XMLHTTP, and MSXML2.ServerXMLHTTP objects and consistently have the same issue.
Here is a code example:
Public Function Send() As Boolean
Dim oXHR As MSXML2.XMLHTTP60
Dim sURL, sCred As String
Dim sRequest, sResult, sStatus, sHeader As String
Dim bRtn As Boolean
BuildReqXML
sRequest = Me.RequestXML_String
With orsValues
sURL = .Fields("WebServiceURL").Value
sCred = Base64Encode(Trim(.Fields("User").Value) & ":" & Trim(.Fields("Password").Value))
End With
Set oXHR = New MSXML2.XMLHTTP60
With oXHR
.Open "POST", sURL, False
.SetRequestHeader "Authorization", "Basic " & sCred & """"
.SetRequestHeader "User-Agent", "Mozilla/4.0"
.SetRequestHeader "Content-Type", "text/xml"
.Send sRequest
sStatus = .StatusText
sResult = .ResponseText
sHeader = .GetAllResponseHeaders
If sResult <> "" Then
If Contains(sResult, "<") Then ReadXML sResult, "Response"
Debug.Print sResult
Else
Debug.Print sHeader
Debug.Print sRequest
End If
End With
Set oXHR = Nothing
End Function
I have verified that the web service is working correctly by building a similar call in a HTML document, sending the XML string, and receiving the response XML string.
Can someone please help me fix my issue?
I found the problem, with help from Fiddler.
The line setting the authorization header
.SetRequestHeader "Authorization", "Basic " & sCred & """"
Was adding a (") to the header line. The corrected line is
.SetRequestHeader "Authorization", "Basic " & sCred
Thank you for your help

Parse/Scrape from Multiple Pages using XMLHTTP in VBA

The code below only scrapes/parses one page of data (50 results) into excel however, I would like it to scrape multiple pages (500 results) - please help. (Base64Encode was taken from a different source - I don't take credit for it)
`Function GetData() As Boolean
Application.ScreenUpdating = False
Dim objHTTP As New MSXML2.XMLHTTP
Dim strURL As String
Dim strUserName As String
Dim strPassword As String
Sheet1.Range("A2:R2000") = ""
Sheet1.Activate
strUserName = "User"
strPassword = "Password"
For i = 1 To UBound(MyArray)
strURL = "https://.ngx.com/ngxcs/indexPrice.xml"
objHTTP.Open "GET", strURL, False
objHTTP.setRequestHeader "Authorization", "Basic " & Base64Encode(strUserName & ":" & strPassword)
objHTTP.setRequestHeader "Host", "secure.example.com"
objHTTP.setRequestHeader "Content-Type", "text"
objHTTP.send "Nothing"
While objHTTP.readyState <> 4
DoEvents
Wend
Dim strResponseReceived As String
strResponseReceived = objHTTP.responseText
Debug.Print objHTTP.responseText
MsgBox strResponseReceived
Dim xDoc As DOMDocument
Set xDoc = New DOMDocument
xDoc.LoadXML objHTTP.responseText`
''''''''''''''''''''''''''''''''''''''''''
Rest of Code that outputs it into excel
Thanks for the Help!