URL Shortening

URL shortening is a technique by which a web Uniform Resource Locator (URL) is abbreviated by using an HTTP Reditect from a much shorter domain. Common URL shortening sites include: tinyURL and bit.ly.

The following code can be added to an Excel spreadsheet to allow API calls to some of these sites to shorten URLs as part of a formula. To date, I have tinyURL, is.gd, jmb.tw and snurl.eu working. I will post updates if and when I get other sites working. Comment back if you have any luck with other sites as well.

Usage follows standard formula formatting with the URL to be shortened as the first parameter and the index of the service to use as the second parameter:

=GetShortURL("https://xpresstechnologysolutions.wordpress.com/",0)

will return

http://tinyurl.com/c8gclmj

Add the following functions to your Excel workbook (Alt-F11 to bring up the VBA window):

Function GetShortURL(url As String, index As Integer) As String
' based on http://chandoo.org/wp/2009/02/05/twitter-from-excel/ 
' tinyurl API creation link from: 
' http://www.wprecipes.com/how-to-automatically-provide-tinyurls-for-your-wordpress-blog-posts 
' 
' Currently supporting the following shorteners, include index number in call to choose shortener, tinyurl is the default 
' 
' ex. =GetShortURL("https://xpresstechnologysolutions.wordpress.com/",0) will return "http://tinyurl.com/c8gclmj" 
' 
' 0 = tinyURL, "http://tinyurl.com/api-create.php?url=" & url 
' 1 = is.gd, "http://is.gd/api.php?longurl=" & url 
' 2 = jmb.tw, "http://jmb.tw/api/create/?newurl=" & url 
' 3 = snurl.eu, "http://snurl.eu/api.php?longurl=" & url 
' 4 = 
' 5 = 
' 6 = 
' 7 = 
' 8 = 
' 9 =

Dim xml As Object 
Set xml = CreateObject("MSXML2.XMLHTTP.6.0")

Select Case index     
     Case 0 ' tinyURL
          xml.Open "POST", "http://tinyurl.com/api-create.php?url=" & url, False
          xml.Send
     Case 1 ' is.gd
          xml.Open "POST", "http://is.gd/create.php?format=simple&url=" & URLEncode(url), False
          xml.Send
     Case 2 ' jmb.tw
          xml.Open "POST", "http://jmb.tw/api/create/?newurl=" & url, False
          xml.Send
     Case 3 ' snurl.eu
          xml.Open "POST", "http://snurl.eu/api.php?longurl=" & url, False
          xml.Send
     Case Else ' default to tinyURL
          xml.Open "POST", "http://tinyurl.com/api-create.php?url=" & url, False
          xml.Send End Select

GetShortURL = xml.responsetext

End Function

Public Function URLEncode( _
     StringVal As String, _
     Optional SpaceAsPlus As Boolean = False _
) As String

Dim StringLen As Long: StringLen = Len(StringVal)

If StringLen > 0 Then
     ReDim result(StringLen) As String
     Dim i As Long, CharCode As Integer
     Dim Char As String, Space As String

     If SpaceAsPlus Then Space = "+" Else Space = "%20"

     For i = 1 To StringLen
          Char = Mid$(StringVal, i, 1)
          CharCode = Asc(Char)
          Select Case CharCode
               Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
                    result(i) = Char
               Case 32
                    result(i) = Space
               Case 0 To 15
                    result(i) = "%0" & Hex(CharCode)
               Case Else
                    result(i) = "%" & Hex(CharCode)
          End Select
     Next i
     URLEncode = Join(result, "")

     End If 
End Function

 

Advertisements

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

%d bloggers like this: