Folks....For some years now I have used the following function in one of my Excel macros to help me compose photo captions from English into French. This AM it started throwing an error, which pointed to the .Send command in the code below:
Public Function getGoogleTranslation(strSource As String, strSourceLang As String, strDestLang As String) As String
Dim strURL As String, x As String
strURL = "http://translate.google.com/translate_a/t?client=t&text=" & _
Replace(strSource, " ", "%20") & _
"&hl=en&sl=" & strSourceLang & _
"&tl=" & strDestLang & "&multires=1&pc=0&rom=1&sc=1"
With CreateObject("msxml2.xmlhttp")
.Open "get", strURL, False
.send
x = .responseText
End With
getGoogleTranslation = Replace(Replace(Split(x, ",")(0), "[", ""), """", "")
End Function
When I copy/paste the contents of strURL directly into IE, the first time I got a CAPTCHA and a comment that they are checking for 'robots'. The second time it worked directly. They must be setting a cookie??
Is there anyway around this? Or another way to get simple phrases translated in a macro?
Thanks....RDK
OK, done with Google Translate! It is no longer free for VBA usage even as small as mine. Now using Microsoft Translator via VBA. Just signed up on Microsoft Azure Marketplace and get 2 million character/month for free.
I've been using this system for several months now and it works as good as Google Translate did. Not perfect, but good enough....RDK
The following is just beta-realisation of a google-translation module for vba:
(used it for fast translation of a software)...
maybe you need manually check the text afterwards for correctness.
Private Function GoogleTranslate(ByVal Text4Translation, ByVal resLang, ByVal srcLang) As String
Dim IEApp As Object
Dim IEDoc As Object
Dim IEUrl As String
Dim IESrc As String
Dim IEBeg As Long
Dim IEEnd As Long
' Neues Browser Objekt erzeugen
Set IEApp = CreateObject("InternetExplorer.Application")
' Browser versteckt ausführen (höhere Geschwindigkeit)
'IEApp.Visible = False
' URL Generieren
Text4Translation = Replace(Text4Translation, " ", "%20")
IEUrl = "https://translate.google.com/#" & srcLang & "/" & resLang & "/" & Text4Translation
' HTML-Datei aufrufen
IEApp.navigate IEUrl
Do
Application.Wait Now + TimeSerial(0, 0, 1)
Loop Until IEApp.busy = False
Set IEDoc = IEApp.document
' Quelltext einlesen
IESrc = IEDoc.body.innerHTML
' Bereich auslesen
IEBeg = InStr(1, IESrc, "result_box")
If IEBeg = 0 Then
IESrc = " # Nothing found"
Else
IEEnd = InStr(IEBeg, IESrc, "</div")
IESrc = Mid(IESrc, IEBeg + 40, IEEnd - IEBeg - 40)
IESrc = Replace(IESrc, "<span class=" & Chr(34) & "hps" & Chr(34) & ">", "")
IESrc = Replace(IESrc, "<span class=" & Chr(34) & "atn" & Chr(34) & ">", "")
IESrc = Replace(IESrc, "<span class=" & Chr(34) & "hps atn" & Chr(34) & ">", "")
IESrc = Replace(IESrc, "<span>", "")
IESrc = Replace(IESrc, "</span>", "")
If IESrc = "" Then IESrc = " # Instr-Error"
End If
Set IEApp = Nothing
GoogleTranslate = IESrc
End Function
resLang = "de","en", ... (TargetLanguage)
srcLang = "de","en", ... (SourceLanguage)
(Attention, its just a workaround!)
Please refer to get Phonetic of Google transcript (As string)
(It's just below TextBox, when translate from English using one word)
Related
I have found a link at SO that may make difference at this query
Upload a Picture to file.io (HTTP Post) in VBA
The code from this link
Sub UploadFilesUsingVBAORIGINAL()
'this proc will upload below files to https://file.io/
' png, jpg, txt
Dim fileFullPath As String
fileFullPath = ThisWorkbook.Path & "\Sample.txt"
POST_multipart_form_dataO fileFullPath
End Sub
Private Function GetGUID() As String
' Generate uuid version 4 using VBA
GetGUID = WorksheetFunction.Concat(WorksheetFunction.Dec2Hex(WorksheetFunction.RandBetween(0, 4294967295#), 8), "-", WorksheetFunction.Dec2Hex(WorksheetFunction.RandBetween(0, 65535), 4), "-", WorksheetFunction.Dec2Hex(WorksheetFunction.RandBetween(16384, 20479), 4), "-", WorksheetFunction.Dec2Hex(WorksheetFunction.RandBetween(32768, 49151), 4), "-", WorksheetFunction.Dec2Hex(WorksheetFunction.RandBetween(0, 65535), 4), WorksheetFunction.Dec2Hex(WorksheetFunction.RandBetween(0, 4294967295#), 8))
End Function
Private Function GetFileSize(fileFullPath As String) As Long
Dim lngFSize As Long, lngDSize As Long
Dim oFO As Object, OFS As Object
lngFSize = 0
Set OFS = CreateObject("Scripting.FileSystemObject")
If OFS.FileExists(fileFullPath) Then
Set oFO = OFS.GetFile(fileFullPath)
GetFileSize = oFO.Size
Else
GetFileSize = 0
End If
Set oFO = Nothing
Set OFS = Nothing
End Function
Private Function ReadBinary(strFilePath As String)
Dim ado As Object, bytFile
Set ado = CreateObject("ADODB.Stream")
ado.Type = 1
ado.Open
ado.LoadFromFile strFilePath
bytFile = ado.Read
ado.Close
ReadBinary = bytFile
Set ado = Nothing
End Function
Private Function toArray(str)
Dim ado As Object
Set ado = CreateObject("ADODB.Stream")
ado.Type = 2
ado.Charset = "_autodetect"
ado.Open
ado.WriteText (str)
ado.Position = 0
ado.Type = 1
toArray = ado.Read()
Set ado = Nothing
End Function
Sub POST_multipart_form_dataO(filePath As String)
Dim oFields As Object, ado As Object
Dim sBoundary As String, sPayLoad As String, GUID As String
Dim fileType As String, fileExtn As String, fileName As String
Dim sName As Variant
fileName = Right(filePath, Len(filePath) - InStrRev(filePath, "\"))
fileExtn = Right(filePath, Len(fileName) - InStrRev(fileName, "."))
Select Case fileExtn
Case "png"
fileType = "image/png"
Case "jpg"
fileType = "image/jpeg"
Case "txt"
fileType = "text/plain"
End Select
Set oFields = CreateObject("Scripting.Dictionary")
With oFields
.Add "qquuid", LCase(GetGUID)
.Add "qqtotalfilesize", GetFileSize(filePath)
End With
sBoundary = String(27, "-") & "7e234f1f1d0654"
sPayLoad = ""
For Each sName In oFields
sPayLoad = sPayLoad & "--" & sBoundary & vbCrLf
sPayLoad = sPayLoad & "Content-Disposition: form-data; name=""" & sName & """" & vbCrLf & vbCrLf
sPayLoad = sPayLoad & oFields(sName) & vbCrLf
Next
sPayLoad = sPayLoad & "--" & sBoundary & vbCrLf
sPayLoad = sPayLoad & "Content-Disposition: form-data; name=""file""; " & "filename=""" & fileName & """" & vbCrLf
sPayLoad = sPayLoad & "Content-Type: " & fileType & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf
sPayLoad = sPayLoad & "--" & sBoundary & "--"
Set ado = CreateObject("ADODB.Stream")
ado.Type = 1
ado.Open
ado.Write toArray(sPayLoad)
ado.Write ReadBinary(filePath)
ado.Position = 0
With CreateObject("MSXML2.ServerXMLHTTP")
.Open "POST", "https://file.io", False
.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & sBoundary
.send (ado.Read())
Debug.Print .responseText
End With
End Sub
Anyone can try this code as the website is for free. When I run the code, I got "Success" in the immediate window and got a link to the uploaded file.
This appears to have no problem but when taking the link and put it in a browser, I got 404 Page not found
I tried uploading the same file manually and it works well without any problem as for the link I got from this manual steps
Any help please?
Posted here too
https://chandoo.org/forum/threads/upload-file-to-file-io-using-post-method.43925/
It looks to me like the final boundary is in the wrong place ie before the file content. Try
Sub UploadToIO()
Const PATH = "c:\tmp\"
Const FILENAME = "testimage.png"
Const CONTENT = "image/png"
Const URL = "https://file.io"
' 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
part = "--" & BOUNDARY & vbCrLf
part = part & "Content-Disposition: form-data; name=""file""; filename=""" & FILENAME & """" & vbCrLf
part = part & "Content-Type: " & CONTENT & vbCrLf & vbCrLf
' read file into image
Dim image
Set ado = CreateObject("ADODB.Stream")
ado.Type = 1 'binary
ado.Open
ado.LoadFromFile PATH & FILENAME
ado.Position = 0
image = ado.read
ado.Close
' combine part, image , end
ado.Open
ado.Position = 0
ado.Type = 1 ' binary
ado.Write ToBytes(part)
ado.Write image
ado.Write ToBytes(vbCrLf & "--" & BOUNDARY & "--")
ado.Position = 0
'ado.savetofile "c:\tmp\debug.bin", 2 ' overwrite
' send request
With CreateObject("MSXML2.ServerXMLHTTP")
.Open "POST", URL, False
.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & BOUNDARY
.send ado.read
Debug.Print .responseText
End With
MsgBox "File: " & PATH & FILENAME & vbCrLf & _
"Boundary: " & BOUNDARY, vbInformation, "Uploaded to " & URL
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
I am trying to utilize a "dictionary" script that I found to define words in a column. VB throws out that error at me and I am clueless as to how to fix it. AM I using anything that a vba app script could understand? Here is the website that I am using to insert this function into excel: https://script.google.com
Code:
Function DefineWord(wordToDefine As String) As String
' Array to hold the response data.
Dim d() As Byte
Dim r As Research
Dim myDefinition As String
Dim PARSE_PASS_1 As String
Dim PARSE_PASS_2 As String
Dim PARSE_PASS_3 As String
Dim END_OF_DEFINITION As String
'These "constants" are for stripping out just the definitions from the JSON data
PARSE_PASS_1 = Chr(34) & "webDefinitions" & Chr(34) & ":"
PARSE_PASS_2 = Chr(34) & "entries" & Chr(34) & ":"
PARSE_PASS_3 = "{" & Chr(34) & "type" & Chr(34) & ":" & Chr(34) & "text" & Chr(34) & "," & Chr(34) & "text" & Chr(34) & ":"
END_OF_DEFINITION = "," & Chr(34) & "language" & Chr(34) & ":" & Chr(34) & "en" & Chr(34) & "}"
Const SPLIT_DELIMITER = "|"
' Assemble an HTTP Request.
Dim url As String
Dim WinHttpReq As Variant
Set WinHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
'Get the definition from Google's online dictionary:
url = "http://www.google.com/dictionary/json?callback=dict_api.callbacks.id100&q=" & wordToDefine & "&sl=en&tl=en&restrict=pr%2Cde&client=te"
WinHttpReq.Open "GET", url, False
' Send the HTTP Request.
WinHttpReq.Send
'Print status to the immediate window
Debug.Print WinHttpReq.Status & " - " & WinHttpReq.StatusText
'Get the defintion
myDefinition = StrConv(WinHttpReq.ResponseBody, vbUnicode)
'Get to the meat of the definition
myDefinition = Mid$(myDefinition, InStr(1, myDefinition, PARSE_PASS_1, vbTextCompare))
myDefinition = Mid$(myDefinition, InStr(1, myDefinition, PARSE_PASS_2, vbTextCompare))
myDefinition = Replace(myDefinition, PARSE_PASS_3, SPLIT_DELIMITER)
'Split what's left of the string into an array
Dim definitionArray As Variant
definitionArray = Split(myDefinition, SPLIT_DELIMITER)
Dim temp As String
Dim newDefinition As String
Dim iCount As Integer
'Loop through the array, remove unwanted characters and create a single string containing all the definitions
For iCount = 1 To UBound(definitionArray) 'item 0 will not contain the definition
temp = definitionArray(iCount)
temp = Replace(temp, END_OF_DEFINITION, SPLIT_DELIMITER)
temp = Replace(temp, "\x22", "")
temp = Replace(temp, "\x27", "")
temp = Replace(temp, Chr$(34), "")
temp = iCount & ". " & Trim(temp)
newDefinition = newDefinition & Mid$(temp, 1, InStr(1, temp, SPLIT_DELIMITER) - 1) & vbLf 'Hmmmm....vbLf doesn't put a carriage return in the cell. Not sure what the deal is there.
Next iCount
'Put list of definitions in the Immeidate window
Debug.Print newDefinition
'Return the value
DefineWord = newDefinition
End Function
This looks like visual basic, Google uses Apps script which is essentially javascipt. In Javascript you terminate statements with semicolon, that's what it's looking for.
link here:Google Help Forum
The title sums this one up.
Basically I would like to download all files that have been modified in a specific range of times so I am in need of a way to get the last modified date of a file in Office365/SharePoint.
Sub TestWhen()
SPFilePath = "http://teams.MyCompany.com/sites/PATH/PATH/Fulfillment/Forms/AllItems.aspx"
Debug.Print SPLastModified(SPFilePath, "2021_MyFileName.xlsx")
End Sub
Function SPLastModified(SPUrl As String, SPFName As String)
Dim PagesHTML As String
Dim Dadate As String
Dim DaDateEnd As String
Dim arr() As String
arr = Split(OutString, " ")
Dim LastChange As Variant
Set ie = CreateObject("InternetExplorer.Application")
With ie
.Visible = True
.navigate SPUrl
Do Until .readyState = 4
DoEvents
Loop
Do While .busy: DoEvents: Loop
Do Until .readyState = 4
DoEvents
Loop
PagesHTML = ie.document.DocumentElement.outerHTML
End With
' Get to File
Dadate = InStr(PagesHTML, "FileLeafRef" & Chr(34) & ": " & Chr(34) & SPFName)
' Get to Modified Date
ModifiedText = "Modified" & Chr(34) & ": "
Dadate = Dadate + InStr(Mid(PagesHTML, Dadate), ModifiedText)
OutString = Mid(PagesHTML, Dadate + Len(ModifiedText), 27)
arr = Split(OutString, " ")
LastChange = arr(1) & " " & arr(2)
LastChange = arr(0) & "/" & Mid(arr(1), 6) & "/" & Mid(arr(2), 6, 4) & " " & LastChange
SPLastModified = LastChange
End Function
To my knowledge there is no way change the date modified. One way would to do, would be to put a workflow and him have a break to the desired date and edit any column, but the modified person would also be changed.
I am using excel VBA to open the first returned page of google result. From the first page, I am manipulating the data based on their element IDs. On doing this process, I am encountering a pretty weird behavior.
Let me give a brief overview of what am trying to do.
I will get the first name and the last name as input in the user form. For the given first name and last name, I will search for the linkedin profile.
For example, if the first name is Sachin and last name is Tendulkar, I will use VBA to pass the search term as Sachin Tendulkar linkedin to the google. For the search results returned, I will open the first search result page and try to get the linkedin profile data.
My code so far is as below.
Private Sub CommandButton1_Click()
Dim ie As InternetExplorer
Dim RegEx As RegExp, RegMatch As MatchCollection
Dim MyStr As String
Dim pDisp As Object
Dim FirstName As String
Dim LastName As String
Dim sample As String
Set ie = New InternetExplorer
Set RegEx = New RegExp
Dim iedoc As Object
Dim openedpage As String
Dim inpagestrt, inpageend As Integer
Dim returnstatement As String
Dim detailname, locationdetails, profileexperience, profilecontact
Dim overview,skillslist, profilelanguages, profileeducation, publicgroups
detailname = ""
returnstatement = ""
locationdetails = ""
profileexperience = ""
profilecontact = ""
overview = ""
skillslist = ""
profilelanguages = ""
profileeducation = ""
publicgroups = ""
FirstName = TextBox1.Value
LastName = TextBox2.Value
ie.Navigate "http://www.google.com/search?hl=en&q=" & FirstName & "+" & LastName & "+linkedin&meta="
Do Until ie.ReadyState = READYSTATE_COMPLETE
Loop
MyStr = ie.Document.body.innerText
Set RegMatch = RegEx.Execute(MyStr)
'If a match to our RegExp searchstring is found then launch this page
If RegMatch.Count > 0 Then
ie.Navigate RegMatch(0)
Do Until ie.ReadyState = READYSTATE_COMPLETE
Loop
'****************************************
'EDITS
'****************************************
Set iedoc = ie.Document
Dim extractedHTML As String
Dim iStart, iEnd As Integer
extractedHTML = iedoc.getElementById("search").innerHTML
iStart = InStr(1, extractedHTML, "href=", vbTextCompare) + Len("href=") + 1
iEnd = InStr(iStart, extractedHTML, Chr(34), vbTextCompare)
'extract the text
extractedHTML = Mid(extractedHTML, iStart, iEnd - iStart)
'go to the URL
ie.Navigate extractedHTML
Set iedoc1 = ie.Document
'MsgBox iedoc1
On Error GoTo ErrHandler:
openedpage = iedoc1.getElementById("name").innerText
detailname = "NAME:" & vbCrLf & FirstName + " " + LastName
MsgBox ""
openedpage = ""
openedpage = iedoc1.getElementById("headline").innerText
'On Error GoTo ErrHandler:
MsgBox "LOCATION DETAILS:" & vbCrLf & openedpage
locationdetails = openedpage + vbCrLf
MsgBox locationdetails
openedpage = iedoc1.getElementById("profile-experience").innerText
profileexperience = openedpage + vbCrLf
openedpage = iedoc1.getElementById("profile-contact").innerText
profilecontact = openedpage + vbCrLf
openedpage = iedoc1.getElementById("overview").innerText
overview = openedpage + vbCrLf
openedpage = iedoc1.getElementById("skills-list").innerText
skillslist = openedpage + vbCrLf
openedpage = iedoc1.getElementById("profile-languages").innerText
profilelanguages = openedpage + vbCrLf
openedpage = iedoc1.getElementById("profile-education").innerText
profileeducation = openedpage + vbCrLf
openedpage = iedoc1.getElementById("pubgroups").innerText
publicgroups = openedpage + vbCrLf
returnstatement = locationdetails + profileexperience + profilecontact + overview + skillslist + profilelanguages + profileeducation + publicgroups
MsgBox returnstatement
ErrHandler:
openedpage = "NULL"
Resume Next
'****************************************
'End EDITS
'****************************************
Else
MsgBox "No linkedin profile found"
End If
Set RegEx = Nothing
Set ie = Nothing
End Sub
The weirdest thing is when I comment line number 59, my location details are returned as NULL. However, if I have that message box the location details are getting returned correctly. I tried using a variable instead of message box but the location details becomes NULL for all the scenarios except when I use the message box.
openedpage = iedoc1.getElementById("name").innerText
detailname = "NAME:" & vbCrLf & FirstName + " " + LastName
**MsgBox ""** (If i comment it out, location details becomes NULL. If it is uncommented, location details value is correct.
openedpage = ""
openedpage = iedoc1.getElementById("headline").innerText
'On Error GoTo ErrHandler:
**MsgBox "LOCATION DETAILS:" & vbCrLf & openedpage**
locationdetails = openedpage + vbCrLf
MsgBox locationdetails
I thing that you macro need some additional time to load all (or some additional) data. If you have you MsgBox in place you unintentionally give the process some time before you find and close you MsgBox.
What if you put other kind of 'waiting' point (like Application.Wait or Do...Loop) instead of MsgBox. Please let us know the result.
Internet Explorer takes some time to load and render a page. Add a line
Do While ie.Busy : WScript.Sleep 100 : Loop
after the instruction ie.Navigate extractedHTML. You're already doing something similar when loading the first page:
ie.Navigate "http://www.google.com/search?hl=en&q=" & FirstName _
& "+" & LastName & "+linkedin&meta="
Do Until ie.ReadyState = READYSTATE_COMPLETE
Loop
although you should add a sleep instruction there, too.
In Excel, if I enter the word "PIZZA" into a cell, select it, and SHIFT+F7, I can get a nice English dictionary definition of my favorite food. Pretty cool.
But I'd like a function that does this. Something like '=DEFINE("PIZZA")'.
Is there a way through VBA scripts to access Microsoft's Research data? I was considering using a JSON parser and a free online dictionary, but it seems like Excel has a nice dictionary built-in. Any ideas on how to access it?
In case VBA's Research object doesn't work out, you can try the Google Dictionary JSON method as so:
First, add a reference to "Microsoft WinHTTP Services".
After you see my mad, JSON parsing skillz, you may also want to add your favorite VB JSON parser, like this one.
Then Create the following Public Function:
Function DefineWord(wordToDefine As String) As String
' Array to hold the response data.
Dim d() As Byte
Dim r As Research
Dim myDefinition As String
Dim PARSE_PASS_1 As String
Dim PARSE_PASS_2 As String
Dim PARSE_PASS_3 As String
Dim END_OF_DEFINITION As String
'These "constants" are for stripping out just the definitions from the JSON data
PARSE_PASS_1 = Chr(34) & "webDefinitions" & Chr(34) & ":"
PARSE_PASS_2 = Chr(34) & "entries" & Chr(34) & ":"
PARSE_PASS_3 = "{" & Chr(34) & "type" & Chr(34) & ":" & Chr(34) & "text" & Chr(34) & "," & Chr(34) & "text" & Chr(34) & ":"
END_OF_DEFINITION = "," & Chr(34) & "language" & Chr(34) & ":" & Chr(34) & "en" & Chr(34) & "}"
Const SPLIT_DELIMITER = "|"
' Assemble an HTTP Request.
Dim url As String
Dim WinHttpReq As Variant
Set WinHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
'Get the definition from Google's online dictionary:
url = "http://www.google.com/dictionary/json?callback=dict_api.callbacks.id100&q=" & wordToDefine & "&sl=en&tl=en&restrict=pr%2Cde&client=te"
WinHttpReq.Open "GET", url, False
' Send the HTTP Request.
WinHttpReq.Send
'Print status to the immediate window
Debug.Print WinHttpReq.Status & " - " & WinHttpReq.StatusText
'Get the defintion
myDefinition = StrConv(WinHttpReq.ResponseBody, vbUnicode)
'Get to the meat of the definition
myDefinition = Mid$(myDefinition, InStr(1, myDefinition, PARSE_PASS_1, vbTextCompare))
myDefinition = Mid$(myDefinition, InStr(1, myDefinition, PARSE_PASS_2, vbTextCompare))
myDefinition = Replace(myDefinition, PARSE_PASS_3, SPLIT_DELIMITER)
'Split what's left of the string into an array
Dim definitionArray As Variant
definitionArray = Split(myDefinition, SPLIT_DELIMITER)
Dim temp As String
Dim newDefinition As String
Dim iCount As Integer
'Loop through the array, remove unwanted characters and create a single string containing all the definitions
For iCount = 1 To UBound(definitionArray) 'item 0 will not contain the definition
temp = definitionArray(iCount)
temp = Replace(temp, END_OF_DEFINITION, SPLIT_DELIMITER)
temp = Replace(temp, "\x22", "")
temp = Replace(temp, "\x27", "")
temp = Replace(temp, Chr$(34), "")
temp = iCount & ". " & Trim(temp)
newDefinition = newDefinition & Mid$(temp, 1, InStr(1, temp, SPLIT_DELIMITER) - 1) & vbLf 'Hmmmm....vbLf doesn't put a carriage return in the cell. Not sure what the deal is there.
Next iCount
'Put list of definitions in the Immeidate window
Debug.Print newDefinition
'Return the value
DefineWord = newDefinition
End Function
After that, it's just a matter of putting the function in your cell:
=DefineWord("lionize")
via the Research object
Dim rsrch as Research
rsrch.Query( ...
To query, you need the GUID of a valid web service. I haven't been able to find the GUID's for Microsoft's built in service though.