Track links in MS Word Document

VBA Project Tree for Bitly URL Shortener in Word 2010

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

Instructions

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 stephan@unrauinnovative.com
' 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

About these ads

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