Was reading the post by Tech Demo Guy and it seemed to be exactly what I wanted – a macro to convert every hyperlink into a bit.ly shortened link. Unfortunately it’s a bit out of date from sometime last year.
It may be Office 2010, 64 bit computer, or newer bit.ly API, and I couldn’t get it to work.
I decided to whip up a modern hackjob for those who just want bit.ly and have no Google Analytics. On the plus side, it’s got improvements to determining if a link should be shortened (will not shorten hyperlinks you put on text or on table of contents for example), since it will only shorten a link that has visible text like this http://www.doin.biz – the prefix of http:// is the determination.
Click the image to download macro document for 64 bit MS Word 2010 working with the latest bit.ly API. Or read on to see how it’s done…
Summary of Improvements
- Can store API key encrypted (minimally)
- Calls bit.ly API with a timer (Default 500 ms)
- UrlEncodes the URLs
- Changes visible text to (link)
- Error handler and completion info
To setup the password protected encrypted bit.ly API key is a bit of a stretch and it’s probably not that necessary so you could comment it out to get it working quicker. I’ve also allowed you to enter a blank password and copy in your API key directly. Haven’t tested but and time! This would probably be better as a .NET Add In to Office. If you have a better one, let me know!
Main VBA Code
(MD5 and Helper class in DOCM)Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) ' Purpose: To alter links to external websites so they appear as (link) and use bit.ly ' Original code from Dav Schigian did not run on my machine (x64, Office 2010, new Bit.Ly API) ' MS Office Word Script, Macro, VBA, Visual Basic for Applications ' Convert all hyperlinks to bit.ly, Convert links to Bit.ly ' Author: Stephan Unrau firstname.lastname@example.org ' Date: 2011-03-02 ' License; Free as in Free Beer ' How to use: ' 1) Use strMD5 = clsHashMD5.DigestStrToHexStr("yourpassword") to get MD5 for your password ' 2) Put this md5 result into strPassHash constant ' 3) Get your API key from bit.ly settings ' 4) call encrypt/decrypt with your apikey and a custom password ' 5) convert the resulting encrypted value into a byte array (i just used debug.print to generate the theArray initialization below and copied it from the immediate window) ' 6) Enter your Bitly Login username ' Good to go.... **To do these you could just add a module and run from there... ' Breaking Changes: ' this one won't shorten an URL that does not start with http:// in the visible text (so no doc links etc) ' It will also rename the visible text of the link to (link) ' Supported Pre-Requisites: ' Tested Office 2010, x64, Bitly only ' Thanks to ' Robert M. Hubley 12/1999 (For the clsMD5 class) - Unmodified code is MD5 class. ' http://bit.ly - API docs can be found here: http://code.google.com/p/bitly-api/wiki/ApiDocumentation ' Dave Sohigian for the original code here http://www.techdemoguy.com/2010/01/track-clicks-from-your-ms-word-resume/ ' Required: EncryptionManager Class ' MD5 class ' Language: Visual Basic For Applications (VBA) ' Apologies: For removing the other link shortener, I shouldn't be spending any time on this kind of thing anyways! ' For not providing an easy no brainer way of generating your pass hash, or the encrypted API key - but you can always remove the password altogether and embed your ' pure api key but I don't recommend it. ' Improvements: It's a hack job I know so if you have it cleaner, I'll happily put a link to yours.... ' XOR encryption may not even beat a determined elementary school child so probably best to improve this Const CONST_PassHash As String = "9B24184CB7318C23ED339F1DD0C6CB68" ' <-- you must edit htis Const CONST_BitlyLogin As String = "me2pcdotcom" ' <-- your bitly login Public theArray(67) As Byte ' init api key array function must load this with your encrypted api key by first using encryptdecrypt function of EncryptionManager ' and then using debug.print to copy the text for each in the assignment Const CONST_iBitlyAPIRepeatRate = 500 ' 500 ms minimum wait between api calls ' not a real api key, so don't bother Private Sub InitAPIKeyArray() theArray(0) = 51 theArray(1) = 28 theArray(2) = 51 theArray(3) = 0 theArray(4) = 81 theArray(5) = 21 theArray(6) = 82 theArray(7) = 23 theArray(8) = 16 theArray(9) = 21 theArray(10) = 9 theArray(11) = 21 theArray(12) = 10 theArray(13) = 21 theArray(14) = 2 theArray(15) = 5 theArray(16) = 8 theArray(17) = 21 theArray(18) = 2 theArray(19) = 21 theArray(20) = 81 theArray(21) = 71 theArray(22) = 68 theArray(23) = 21 theArray(24) = 95 theArray(25) = 21 theArray(26) = 9 theArray(27) = 21 theArray(28) = 81 theArray(29) = 37 theArray(30) = 83 theArray(31) = 23 theArray(32) = 5 theArray(33) = 0 theArray(34) = 83 theArray(35) = 23 theArray(36) = 67 theArray(37) = 23 theArray(38) = 17 theArray(39) = 0 theArray(40) = 23 theArray(41) = 23 theArray(42) = 87 theArray(43) = 23 theArray(44) = 0 theArray(45) = 33 theArray(46) = 84 theArray(47) = 32 theArray(48) = 88 theArray(49) = 89 theArray(50) = 67 theArray(51) = 23 theArray(52) = 95 theArray(53) = 73 theArray(54) = 9 theArray(55) = 53 theArray(56) = 3 theArray(57) = 23 theArray(58) = 11 theArray(59) = 23 theArray(60) = 87 theArray(61) = 23 theArray(62) = 93 theArray(63) = 13 theArray(64) = 63 theArray(65) = 23 theArray(66) = 18 theArray(67) = 23 End Sub Sub URLShortener() On Error GoTo ErrorHandler Dim strMessages As String ' message log for user to see at end Dim strPassHash As String Dim strString As String Dim iTotalLinks As Integer Dim iTotalChanged As Integer Dim strPass As String Dim em As New EncryptionManager Dim strMD5 As String BitlyAPIKey = "" iTotalLinks = 0 iTotalChanged = 0 strMessages = "" Call InitAPIKeyArray ' initialize theArray API key encrypted strString = theArray strPass = CStr(InputBox("Password Required or leave blank to enter raw api key")) ' Get password ' validate password strMD5 = em.HashMD5.DigestStrToHexStr(SourceString:=strPass) If (strMD5 <> CONST_PassHash) Then MsgBox ("Incorrect Password, find your raw API key...") BitlyAPIKey = CStr(InputBox("Enter key", "Bit.ly API key")) If (BitlyAPIKey = "") Then MsgBox ("No key entered, exiting") Exit Sub End If End If ' correct, lets decrypt key if it wasn't entered manually If (BitlyAPIKey = "") Then em.EncryptDecrypt sDataToCipher:=strString, strPassword:=strPass BitlyAPIKey = strString End If Set ObjHttp = CreateObject("MSXML2.XMLHTTP") ' cant' send calls too quikcly to them dtLastBitlyAPICall = DateAdd("s", -10, Now()) 'Loop through all of the hyperlinks and shorten the URLs iTotalLinks = ActiveDocument.Hyperlinks.Count For I = 1 To ActiveDocument.Hyperlinks.Count ApiUrl = "" LinkText = "" ' select the next hyperlink ActiveDocument.Hyperlinks(I).Range.Select ' store the name of the hyperlink LinkText = ActiveDocument.Hyperlinks(I).TextToDisplay ' store the url of the hyperlink linkUrl = ActiveDocument.Hyperlinks(I).Address ' slight change here - only set to bitly a link which has visible text that starts with http:// any hyper link on other text would not be ' set to bitly ' Make sure it is not a bit.ly or cligs url (would error out) If (Left(LinkText, 13) <> "http://bit.ly") And (Left(LinkText, 13) <> "http://cli.gs") And (Left(LinkText, 7) = "http://") Then If (BitlyAPIKey <> "") Then ' Create the API URL for Bitly If DateTime.DateDiff("s", dtLastBitlyAPICall, DateTime.Now) = 0 Then Sleep (iBitlyAPIRepeatRate) End If ApiUrl = "http://api.bitly.com/v3/shorten?version=2.0.1&login=" _ & CONST_BitlyLogin & "&apiKey=" & BitlyAPIKey & "&history=1&format=txt&longUrl=" _ & em.UrlEncode(linkUrl) End If If (ApiUrl <> "") Then ' Setup the call to the REST API ObjHttp.Open "GET", ApiUrl, False ' False indicates the call is synchronous - wait for URL Result ' Send the request ObjHttp.send ' Get our results (the shortened URL) if the response was okay If (ObjHttp.StatusText = "OK") Then StrResult = ObjHttp.responseText iTotalChanged = iTotalChanged + 1 Else strMessages = strMessages & "Error for [" & linkUrl & "]" & ObjHttp.responseText & vbCrLf StrResult = linkUrl End If 'Otherwise just keep the original URL Else StrResult = linkUrl End If ActiveDocument.Hyperlinks.Add Address:=StrResult, Anchor:=Selection.Range, ScreenTip:=linkUrl, TextToDisplay:="(Link)", Target:="_blank" End If Next I GoTo Done ErrorHandler: MsgBox Err.Number & " - " & Err.Description GoTo Done Success: MsgBox "Success, be sure to test the links first." strMessages = strMessages & "Completed, checked " & iTotalLinks & " links." & vbCrLf strMessages = strMessages & "Changed " & iTotalLinks & " links to bit.ly" & vbCrLf GoTo Done Done: Set ObjHttp = Nothing End Sub