Another URL shortener API

I've posted code for several URL shorteners already:

• Create Tiny URLs using VBA
• bit.ly API v3 update

Here's one more, using the API for omani.ac.

This code has a lot in common with the previous post's code for the scr.im API:

• Requires POST request (syntax courtesy of Excel Geek)
• Uses MSXML6.DLL (late bound)
• API response is cached to limit bandwidth usage

However, in this function we do check for a valid URL before continuing.

Function GetShortURL(longURL As String, _
    Optional forceRequery As Boolean = False) As String
' http://omani.ac/
Dim xml As Object ' MSXML2.XMLHTTP
Dim xmlDoc As Object ' MSXML2.DOMDocument
Dim xmlDocRoot As Object ' MSXML2.IXMLDOMNode
Dim result As String
Dim results() As String
Dim tempFile As String

Const XML_FILE_EXTENSION As String = ".xml"
Const BASE_URL As String = "http://omani.ac/api/shorten.xml"

  ' check for valid string
  If Len(longURL) = 0 Then
    Exit Function
  End If

  tempFile = environ("temp") & "\" & _
    Replace(Replace(longURL, "/", "_"), ":", "+") & XML_FILE_EXTENSION

  ' requery if cache file is missing or forceRequery set to True
  If Len(Dir(tempFile)) = 0 Or forceRequery Then

    Set xml = GetMSXML

    ' check for valid url
    With xml
      .Open "GET", longURL, False
      .send
      If .Status <> "200" Then
        Exit Function
      End If
    End With

    With xml
      .Open "POST", BASE_URL, False
      .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
      .send "url=" & longURL
    End With

    result = xml.responseText

    CreateFile tempFile, result

  End If

  ' load XML file into new XML document
  Set xmlDoc = GetDomDoc

  With xmlDoc
    .async = False
    .validateOnParse = False
    .Load tempFile
  End With

  ' check that the XML doc loaded
  If LoadError(xmlDoc) Then
    Exit Function
  End If

  ' get root node
  Set xmlDocRoot = GetRootNode(xmlDoc)

  ' grab last sub-node's value, even if it's an error
    GetShortURL = GetNode(xmlDocRoot, xmlDocRoot.childNodes.Length).nodeTypedValue

End Function

You'll need to check for return values that are either empty (invalid URL) or error values. See omani.ac for a list of error codes.

Helper Functions

Paste these helper functions into a standard module in the same project as the above function. They are all used by the function above.

You'll also need to grab the URLEncode function, courtesy of our friends at Free VB Code.

Sample Usage

Sub TestURLs()

Debug.Print GetShortURL("http://www.google.com/")

End Sub

They also have a "lengthen" method, for taking omani.ac URLs and converting them back to the original (longer) URL. Extra credit for anyone who wants to tackle that challenge!