Cricalix.Net

Indexing my books – part two

VBA is a horrible thing to work with; mostly because the development environment (if you can call it that) built in to Office 2013 stinks. You get lovely errors like “Access denied” when using the HTTP request component, or “-91”.

So, with a lot of looking things up on StackOverflow and other sources, I’ve re-written the code from the previous post to work with LibraryThing. LibraryThing requires a developer key, but it’s easy enough to get one after creating an account with them. Then you just need the magical getwork API call, and presto, an XML response awaiting your parsing pleasure.

StackOverflow references for this code:

  • Setting a namespace for the XPath query, after getting frustrated that “//title” didn’t work.
  • Using the Server variant of the HTTP fetcher, to get around the Access Denied errors when trying to fetch the HTTPS URL. Wireshark was saying that no packets were even going to the remote website.
  • Tomalak’s fantastic answer with the bulk of the bits I needed to make this all work; I’m more at home in Python.
Option Explicit
Sub ISBN()
    Dim urlBase As String
    Dim libraryThingDoc As MSXML2.DOMDocument60
    Dim oSeqNodes As IXMLDOMNode
    Dim r As String
    Dim title As String
    urlBase = "http://www.librarything.com/services/rest/1.1/?method=librarything.ck.getwork&apikey=API_KEY_GOES_HERE&isbn="
    Do
        r = CStr(ActiveCell.Value)
        title = Nothing
        Set libraryThingDoc = GetXmlDoc(urlBase + r)
        libraryThingDoc.setProperty "SelectionNamespaces", "xmlns:a='http://www.librarything.com/'"
        title = libraryThingDoc.SelectSingleNode("//a:title").Text
        On Error Resume Next
        ActiveCell.Offset(0, 1).Value = title
        ActiveCell.Offset(1, 0).Select
    Loop Until IsEmpty(ActiveCell.Value)
 End Sub
Private Function GetText(context As IXMLDOMNode, path As String) As String
    Dim result As IXMLDOMNode
    If Not context Is Nothing Then
        Set result = context.SelectSingleNode(path)
        If Not result Is Nothing Then GetText = result.Text
    End If
End Function
Private Function GetXmlDoc(url As String) As MSXML2.DOMDocument60
    With New MSXML2.ServerXMLHTTP60
        .Open "GET", url, False
        .send
        If .Status = 200 Then
            If .responseXML.parseError.ErrorCode = 0 Then
                Set GetXmlDoc = .responseXML
            Else
                Err.Raise vbObjectError + 1, "GetXmlDoc", "XML parser error: " & .responseXML.parseError.reason
            End If
        Else
            Err.Raise vbObjectError + 2, "GetXmlDoc", "Server responded with status code " & .Status
       End If
    End With
End Function

Tags: