Finding the English definition of a word in VBA

Question

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?

Answer 1

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")

Answer 2

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.