I am using the VBA code below to decode base64 to XML. It works, but only for small size base64 strings. How can I improve it for long strings ?
Function f_textBase64Decode(strBase64)
Dim b
With CreateObject("Microsoft.XMLDOM").createElement("b64")
.DataType = "bin.base64": .Text = strBase64
b = .nodeTypedValue
With CreateObject("ADODB.Stream")
.Open: .Type = 1: .Write b: .Position = 0: .Type = 2: .Charset = "utf-8"
f_textBase64Decode = .ReadText
.Close
End With
End With
End Function
Related
I'm using Application.FileDialog(msoFileDialogFolderPicker) to pick a folder and it handles well folders with utf8 names.
But when I try to Debug.Print the result of SelectedItems(1) or save it to a config file or do anything, I loose the accents of the folder.
For example:
Original folder:
"D:\Śākta"
'Debug.Print' or saving into an utf8 file result saves:
"D:\Sakta" (removed all the accents)
The problem is that I try to save the selected folder to a config file and when I try to load it, next time it will of course won't recognize as a real folder because of the missing accents.
How to get the real name of the folder with the accents to be able to save it after, not this "representation" of it?
Update:
Just checked, and even the InputBox kills the accents!
#John Coleman's answer solved the issue switching the file saving to 'ADODB.Stream'
Here is an example of reading and writing config file supporting UTF8:
Public Function fileExists(ByVal fullFilename As String) As Boolean
fileExists = CreateObject("Scripting.FileSystemObject").fileExists(fullFilename)
End Function
Public Function ReadTextFile(ByVal sPath As String) As String
If fileExists(sPath) Then
Dim fsT As Object
Set fsT = CreateObject("ADODB.Stream")
fsT.Mode = adModeRead
fsT.Type = 2 'Specify stream type - we want To save text/string data.
fsT.Charset = "utf-8" 'Specify charset For the source text data.
fsT.Open 'Open the stream And write binary data To the object
fsT.LoadFromFile (sPath)
ReadTextFile = fsT.ReadText
fsT.Close
Set fsT = Nothing
Else
ReadTextFile = ""
End If
End Function
Public Function WriteTextFile(ByVal s As String, ByVal sPath As String) As Boolean
Dim objStreamUTF8NoBOM: Set objStreamUTF8NoBOM = CreateObject("ADODB.Stream")
Dim fsT As Object
Set fsT = CreateObject("ADODB.Stream")
fsT.Type = 2 'Specify stream type - we want To save text/string data.
fsT.Charset = "utf-8" 'Specify charset For the source text data.
fsT.Open 'Open the stream And write binary data To the object
fsT.WriteText s
fsT.Position = 0
fsT.SaveToFile sPath, 2 'Save binary data To disk
fsT.Position = 3
With objStreamUTF8NoBOM
.Type = 1
.Open
fsT.CopyTo objStreamUTF8NoBOM
.SaveToFile sPath, 2
Close
End With
fsT.Close
Set fsT = Nothing
Set objStreamUTF8NoBOM = Nothing
End Function
Function SetSettings(ByVal Keyname As String, ByVal Wstr As String) As String
Dim settingsFileContent
settingsFileContent = ReadTextFile(IniFileName)
Set RE = CreateObject("VBScript.RegExp")
RE.Pattern = Keyname + "=.*"
RE.MultiLine = 1
If RE.Test(settingsFileContent) Then
settingsFileContent = RE.Replace(settingsFileContent, Keyname + "=" + Wstr)
Else
settingsFileContent = settingsFileContent + IIf(Len(settingsFileContent) = 0, "", vbNewLine) + Keyname + "=" + Wstr
End If
WriteTextFile settingsFileContent, IniFileName
SetSettings = Wstr
End Function
Private Function GetSettings(ByVal Keyname As String) As String
Dim settingsFileContent As String
settingsFileContent = ReadTextFile(IniFileName)
Set RE = CreateObject("VBScript.RegExp")
RE.MultiLine = 1
RE.Global = 1
RE.Pattern = "\r"
settingsFileContent = RE.Replace(settingsFileContent, "")
RE.Global = 0
RE.Pattern = "^" + Keyname + "=(.*)"
Set allMatches = RE.Execute(settingsFileContent)
If allMatches.Count <> 0 Then
Debug.Print (Keyname + ": """ + allMatches.Item(0).SubMatches.Item(0) + """")
GetSettings = allMatches.Item(0).SubMatches.Item(0)
Else
GetSettings = ""
End If
End Function
I am using MSXML2.XMLHTTP method for data extraction but unable to extract data from specific page
Currently using following code for data extraction from different pages.This code is working fine with other pages but not working proper for specific page.
I want to extract following values for sample page.Price,Seller name etc
Dim http As Object, html As New MSHTML.HTMLDocument, topics As Object, titleElem As Object, detailsElem As Object, topic As HTMLHtmlElement
Dim j As Long
Dim RowCount As String
Dim maxid As Long
Dim productdesc1 As String
Dim features As String
Dim news As String
Dim comb As String
t122 = Now
Rin = DMin("[id]", "url", "[Flag] = False")
If Not IsNull(Rin) Then
Set http = CreateObject("MSXML2.XMLHTTP")
'http = http.SetOption(2, 13056)
'; //ignore all SSL Cert issues
RowCount = DMin("[id]", "url", "[Flag] = False")
maxid = DMax("[id]", "url", "[Flag] = False")
'MsgBox (RowCount)
Do While RowCount <> ""
'RowCount = DMin("[id]", "url", "[Flag] = False")
url = DLookup("[url]", "url", "ID = " & ([RowCount]))
url = Trim(url)
t31 = ""
t31 = (DateDiff("n", t122, Now))
On Error Resume Next
http.Open "GET", url, False
http.Send
html.body.innerHTML = http.ResponseText
brand = html.body.innerText
Set my_data1 = html.getElementsByClassName("a-row a-spacing-mini olpOffer")
i = 1
For Each Item In my_data1
pr1 = Item.getElementsByClassName("a-size-large a-color-price olpOfferPrice a-text-bold")
pr2 = pr1.innerText
dlmsg = Item.innerHTML
If dlmsg Like "*olpShippingPrice*" Then
dpr = Item.getElementsByClassName("olpShippingPrice")
dpr2 = dpr.innerText
End If
Data should be visible from following webpage using above code.https://www.amazon.co.uk/gp/offer-listing/B00551P0Q8
The following will print out all. You can sort where to write the values to
Option Explicit
Public Sub Test()
Dim prices As Object, sellers As Object, html As HTMLDocument, i As Long
Set html = New HTMLDocument
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://www.amazon.co.uk/gp/offer-listing/B01GK4YHMQ", False
.Send
html.body.innerHTML = .ResponseText
End With
Set prices = html.querySelectorAll(".olpOfferPrice")
Set sellers = html.querySelectorAll(".olpSellerName a")
For i = 0 To prices.Length - 1
Debug.Print Trim$(prices.Item(i).innerText)
Debug.Print Trim$(sellers.Item(i).innerText)
Next
End Sub
I am trying to automate downloading of .csv files from http://www.nasdaqomxnordic.com using Excel 2010 VBA and Internet Explorer.
How to automate answering the download prompt with Save?
Before I get to the download part the VBA code needs to click on a button with this web html code:
<div class="button showHistory floatRight">Visa historik</div>
I am using this VBA code:
Set anchorElement = Document.getElementsByClassName("button showHistory floatRight").Item(Index:=1)
anchorElement.Click
This works when I step through the code but when I run it I get an error message on the line anchorElement.Click:
Object variable or With-block variable is not specified.
Any suggestions on 1 or 2?
Consider downloading historic data for shares via XMLHttpRequest instead of IE automation. In the example below share ISIN is specified (SE0001493776 for AAK), first request returns share id (SSE36273), and second request retrieves historic data by id, then shows it in notepad as text, and saves as csv file.
Sub Test()
Dim dToDate, dFromDate, aDataBinary, sShareISIN, sShareId
dToDate = Date ' current day
dFromDate = DateAdd("yyyy", -1, dToDate) ' one year ago
sShareISIN = "SE0001493776" ' for AAK
sShareId = GetId(sShareISIN) ' SSE36273
aDataBinary = GetHistoryData(sShareId, dFromDate, dToDate)
ShowInNotepad BytesToText(aDataBinary, "us-ascii")
SaveBytesToFile aDataBinary, "C:\Test\HistoricData" & sShareId & ".csv"
End Sub
Function GetId(sName)
Dim oJson
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "http://www.nasdaqomxnordic.com/webproxy/DataFeedProxy.aspx?SubSystem=Prices&Action=Search&InstrumentISIN=" & EncodeUriComponent(sName) & "&json=1", False
.Send
Set oJson = GetJsonDict(.ResponseText)
End With
GetId = oJson("inst")("#id")
CreateObjectx86 , True ' close mshta host window at the end
End Function
Function EncodeUriComponent(strText)
Static objHtmlfile As Object
If objHtmlfile Is Nothing Then
Set objHtmlfile = CreateObject("htmlfile")
objHtmlfile.parentWindow.execScript "function encode(s) {return encodeURIComponent(s)}", "jscript"
End If
EncodeUriComponent = objHtmlfile.parentWindow.encode(strText)
End Function
Function GetJsonDict(JsonString)
With CreateObjectx86("ScriptControl") ' create ActiveX via x86 mshta host, for 64-bit office compatibility
.Language = "JScript"
.ExecuteStatement "function gettype(sample) {return {}.toString.call(sample).slice(8, -1)}"
.ExecuteStatement "function evaljson(json, er) {try {var sample = eval('(' + json + ')'); var type = gettype(sample); if(type != 'Array' && type != 'Object') {return er;} else {return getdict(sample);}} catch(e) {return er;}}"
.ExecuteStatement "function getdict(sample) {var type = gettype(sample); if(type != 'Array' && type != 'Object') return sample; var dict = new ActiveXObject('Scripting.Dictionary'); if(type == 'Array') {for(var key = 0; key < sample.length; key++) {dict.add(key, getdict(sample[key]));}} else {for(var key in sample) {dict.add(key, getdict(sample[key]));}} return dict;}"
Set GetJsonDict = .Run("evaljson", JsonString, Nothing)
End With
End Function
Function CreateObjectx86(Optional sProgID, Optional bClose = False)
Static oWnd As Object
Dim bRunning As Boolean
#If Win64 Then
bRunning = InStr(TypeName(oWnd), "HTMLWindow") > 0
If bClose Then
If bRunning Then oWnd.Close
Exit Function
End If
If Not bRunning Then
Set oWnd = CreateWindow()
oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID): End Function", "VBScript"
End If
Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)
#Else
If Not bClose Then Set CreateObjectx86 = CreateObject(sProgID)
#End If
End Function
Function CreateWindow()
' source http://forum.script-coding.com/viewtopic.php?pid=75356#p75356
Dim sSignature, oShellWnd, oProc
On Error Resume Next
sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe ""about:<head><script>moveTo(-32000,-32000);document.title='x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 0, False
Do
For Each oShellWnd In CreateObject("Shell.Application").Windows
Set CreateWindow = oShellWnd.GetProperty(sSignature)
If Err.Number = 0 Then Exit Function
Err.Clear
Next
Loop
End Function
Function GetHistoryData(sId, dFromDate, dToDate)
Dim oParams, sPayload, sParam
Set oParams = CreateObject("Scripting.Dictionary")
oParams("Exchange") = "NMF"
oParams("SubSystem") = "History"
oParams("Action") = "GetDataSeries"
oParams("AppendIntraDay") = "no"
oParams("Instrument") = sId
oParams("FromDate") = ConvDate(dFromDate)
oParams("ToDate") = ConvDate(dToDate)
oParams("hi__a") = "0,5,6,3,1,2,4,21,8,10,12,9,11"
oParams("ext_xslt") = "/nordicV3/hi_csv.xsl"
oParams("OmitNoTrade") = "true"
oParams("ext_xslt_lang") = "en"
oParams("ext_xslt_options") = ",,"
oParams("ext_contenttype") = "application/ms-excel"
oParams("ext_xslt_hiddenattrs") = ",iv,ip,"
sPayload = "xmlquery=<post>"
For Each sParam In oParams
sPayload = sPayload & "<param name=""" & sParam & """ value=""" & oParams(sParam) & """/>"
Next
sPayload = sPayload & "</post>"
With CreateObject("MSXML2.XMLHTTP")
.Open "POST", "http://www.nasdaqomxnordic.com/webproxy/DataFeedProxy.aspx", False
.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
.Send sPayload
GetHistoryData = .ResponseBody
End With
End Function
Function LZ(sValue, nDigits)
LZ = Right(String(nDigits, "0") & CStr(sValue), nDigits)
End Function
Function ConvDate(d)
ConvDate = Year(d) & "-" & LZ(Month(d), 2) & "-" & LZ(Day(d), 2)
End Function
Function BytesToText(aBytes, sCharSet)
With CreateObject("ADODB.Stream")
.Type = 1 ' adTypeBinary
.Open
.Write aBytes
.Position = 0
.Type = 2 ' adTypeText
.Charset = sCharSet
BytesToText = .ReadText
.Close
End With
End Function
Sub SaveBytesToFile(aBytes, sPath)
With CreateObject("ADODB.Stream")
.Type = 1 ' adTypeBinary
.Open
.Write aBytes
.SaveToFile sPath, 2 ' adSaveCreateOverWrite
.Close
End With
End Sub
Sub ShowInNotepad(sContent)
Dim sTmpPath
With CreateObject("Scripting.FileSystemObject")
sTmpPath = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%TEMP%") & "\" & .GetTempName
With .CreateTextFile(sTmpPath, True, True)
.WriteLine (sContent)
.Close
End With
CreateObject("WScript.Shell").Run "notepad.exe " & sTmpPath, 1, True
.DeleteFile (sTmpPath)
End With
End Sub
UPDATE
Note that the above approach makes the system vulnerable in some cases, since it allows the direct access to the drives (and other stuff) for the malicious JS code via ActiveX's. Let's suppose you are parsing web server response JSON, like JsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\\Test.txt')})()}". After evaluating it you'll find new created file C:\Test.txt. So JSON parsing with ScriptControl ActiveX is not a good idea. Check the update of my answer for the RegEx-based JSON parser.
I have a case in which I have field name as Order date for which I need to make it as always valid and it should be valid always.
Below is the script I tried.
Public Function getFolderDetails_FromPath_ForEmailInvoice(ByVal pXDoc As CASCADELib.CscXDocument) As String
On Error GoTo PROC_ERR
Const cProcName = "getFolderDetails_FromPath_ForEmailInvoice"
DbgOut(cProcName, Err, "Start")
Dim FullPath As String
Dim PathArry() As String
Dim FolderName As String
Dim FolderProp() As String
Dim xfolder As CscXFolder
Set xfolder = pXDoc.ParentFolder
While Not xfolder.IsRootFolder
Set xfolder = xfolder.ParentFolder
Wend
'Added below line for KTM testing
'FullPath="F:\EmailImport\chirag#gmail.com_08-01-2014_00-00-00\Demo_Manipulados_02.TIF"
If xfolder.XValues.ItemExists("AC_FIELD_OriginalFileName") Then
FullPath= xfolder.XValues.ItemByName("AC_FIELD_OriginalFileName").Value
End If
PathArry() = Split(FullPath,"\")
FolderName = PathArry(UBound(PathArry())-1)
FolderProp() = Split(FolderName,"_")
If CInt(UBound(FolderProp()))=2 Then
If(ValidateEmailAddress(FolderProp(0))) Then
pXDoc.Fields.ItemByName("Email_ID").Text = FolderProp(0)
pXDoc.Fields.ItemByName("Email_ID").ForcedValid = True
pXDoc.Fields.ItemByName("ReceiveDate").Text = FolderProp(1)
ValidationForm.Fields.ItemByName("ReceiveDate").Enabled = False
pXDoc.Fields.ItemByName("ReceiveDate").OriginalValid = True
pXDoc.Fields.ItemByName("Email_Time").Text = FolderProp(2)
pXDoc.Fields.ItemByName("Email_Time").ForcedValid = True
Else
pXDoc.Fields.ItemByName("Email_ID").Text = ""
pXDoc.Fields.ItemByName("Email_ID").ForcedValid = True
pXDoc.Fields.ItemByName("Email_Time").Text = ""
pXDoc.Fields.ItemByName("Email_Time").ForcedValid = True
End If
Else
pXDoc.Fields.ItemByName("Email_ID").Text = ""
pXDoc.Fields.ItemByName("Email_ID").ForcedValid = True
pXDoc.Fields.ItemByName("Email_Time").Text = ""
pXDoc.Fields.ItemByName("Email_Time").ForcedValid = True
End If
Use this property to make field valid always true:
pXDoc.Fields.ItemByName("Email_Time").ExtractionConfident = True
I've been stuck on this one for a few days with no progress. Using classic ASP, I need to take an uploaded .JPG file (from html form input type='file') and base64 encode it so that I can send it to a Java web service. The Java web service is simply storing the image (in a SQL image field) in a database. I figured converting to BASE64 was the best way to transfer the parameter in the xml. Here's what I have so far:
HTML:
<label>Upload Picture</label>
<input name="file" id="file" type="file" size=40 /> <br />
ASP:
Dim load
Set load = new Loader
load.initialize
Dim fileData
fileData = load.getFileData("file")
Dim fileName
fileName = LCase(load.getFileName("file"))
Dim fileSize
fileSize = load.getFileSize("file")
Dim objXML
Dim objNode
Dim strB64
Set objXML = Server.CreateObject("MSXML2.DomDocument.3.0")
Set objNode = objXML.createElement("base64")
objNode.dataType = "bin.base64" 'stores binary as base64 string
objNode.nodeTypedValue = fileData 'binary value
strB64 = objNode.Text
LOADER:
the loader is a lot of code (I can copy all of it here if needed). It essentially gets all the bytes from the request and parses them into a dictionary object. Here's how it gets the data:
Class Loader
Private dict
Private Sub Class_Initialize
Set dict = Server.CreateObject("Scripting.Dictionary")
End Sub
Public Sub Initialize
If Request.TotalBytes > 0 Then
Dim binData
binData = Request.BinaryRead(Request.TotalBytes)
getData binData
End If
End Sub
Public Function getFileData(name) '"file"
If dict.Exists(name) Then
getFileData = dict(name).Item("Value")
Else
getFileData = ""
End If
End Function
I can post the sub that parses and stores the binary in a dictionary if needed.
The above code gives this error:
msxml3.dll error '80004005'
Error parsing '????' as bin.base64 datatype.
on this line:
objNode.nodeTypedValue = fileData 'binary value
UPDATE:
Here's where the data is loaded to the dictionary:
Private Sub getData(rawData)
Dim separator
separator = MidB(rawData, 1, InstrB(1, rawData, ChrB(13)) - 1)
Dim lenSeparator
lenSeparator = LenB(separator)
Dim currentPos
currentPos = 1
Dim inStrByte
inStrByte = 1
Dim value, mValue
Dim tempValue
tempValue = ""
While inStrByte > 0
inStrByte = InStrB(currentPos, rawData, separator)
mValue = inStrByte - currentPos
If mValue > 1 Then
value = MidB(rawData, currentPos, mValue)
Dim begPos, endPos, midValue, nValue
Dim intDict
Set intDict = Server.CreateObject("Scripting.Dictionary")
begPos = 1 + InStrB(1, value, ChrB(34))
endPos = InStrB(begPos + 1, value, ChrB(34))
nValue = endPos
Dim nameN
nameN = MidB(value, begPos, endPos - begPos)
Dim nameValue, isValid
isValid = True
If InStrB(1, value, stringToByte("Content-Type")) > 1 Then
begPos = 1 + InStrB(endPos + 1, value, ChrB(34))
endPos = InStrB(begPos + 1, value, ChrB(34))
If endPos = 0 Then
endPos = begPos + 1
isValid = False
End If
midValue = MidB(value, begPos, endPos - begPos)
intDict.Add "FileName", trim(byteToString(midValue))
begPos = 14 + InStrB(endPos + 1, value, stringToByte("Content-Type:"))
endPos = InStrB(begPos, value, ChrB(13))
midValue = MidB(value, begPos, endPos - begPos)
intDict.Add "ContentType", trim(byteToString(midValue))
begPos = endPos + 4
endPos = LenB(value)
nameValue = MidB(value, begPos, ((endPos - begPos) - 1))
Else
nameValue = trim(byteToString(MidB(value, nValue + 5)))
End If
If isValid = True Then
intDict.Add "Value", nameValue
intDict.Add "Name", nameN
dict.Add byteToString(nameN), intDict
End If
End If
currentPos = lenSeparator + inStrByte
Wend
End Sub
Private Function stringToByte(toConv)
Dim tempChar, i
For i = 1 to Len(toConv)
tempChar = Mid(toConv, i, 1)
stringToByte = stringToByte & chrB(AscB(tempChar))
Next
End Function
Private Function byteToString(toConv)
dim i
For i = 1 to LenB(toConv)
byteToString = byteToString & chr(AscB(MidB(toConv,i,1)))
Next
End Function
I finally found something that works! Here's the link:
http://www.motobit.com/tips/detpg_binarytostring/
The issue I was having was that the data from the BinaryRead was multibyte data (which ASP doesn't play well with). MultiByte data must be converted To VT_UI1 | VT_ARRAY in order for the base64 encoding via the Dom Document Object (or nearly any other function - including loading to a stream). This can be achieved using an ADO recordset object as such:
Function MultiByteToBinary(MultiByte)
' 2000 Antonin Foller, http://www.motobit.com
' MultiByteToBinary converts multibyte string To real binary data (VT_UI1 | VT_ARRAY)
' Using recordset
Dim RS, LMultiByte, Binary
Const adLongVarBinary = 205
Set RS = CreateObject("ADODB.Recordset")
LMultiByte = LenB(MultiByte)
If LMultiByte>0 Then
RS.Fields.Append "mBinary", adLongVarBinary, LMultiByte
RS.Open
RS.AddNew
RS("mBinary").AppendChunk MultiByte & ChrB(0)
RS.Update
Binary = RS("mBinary").GetChunk(LMultiByte)
End If
MultiByteToBinary = Binary
End Function
Hopefully this will help someone else as well.
Let ADODB.Stream do your heavy lifting, this assumes you already have saved the file to disk. These are the functions for BASE64 I use, I'm not 100% sure where I originally got them.
private function readBytes(file)
dim inStream
' ADODB stream object used
set inStream = WScript.CreateObject("ADODB.Stream")
' open with no arguments makes the stream an empty container
inStream.Open
inStream.type= TypeBinary
inStream.LoadFromFile(file)
readBytes = inStream.Read()
end function
private function encodeBase64(bytes)
dim DM, EL
Set DM = CreateObject("Microsoft.XMLDOM")
' Create temporary node with Base64 data type
Set EL = DM.createElement("tmp")
EL.DataType = "bin.base64"
' Set bytes, get encoded String
EL.NodeTypedValue = bytes
encodeBase64 = EL.Text
end function
private function decodeBase64(base64)
dim DM, EL
Set DM = CreateObject("Microsoft.XMLDOM")
' Create temporary node with Base64 data type
Set EL = DM.createElement("tmp")
EL.DataType = "bin.base64"
' Set encoded String, get bytes
EL.Text = base64
decodeBase64 = EL.NodeTypedValue
end function
private Sub writeBytes(file, bytes)
Dim binaryStream
Set binaryStream = CreateObject("ADODB.Stream")
binaryStream.Type = adTypeBinary
'Open the stream and write binary data
binaryStream.Open
binaryStream.Write bytes
'Save binary data to disk
binaryStream.SaveToFile file, adSaveCreateOverWrite
End Sub