Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub GetURLmetrics()
'----------------------------------------------------------------------------------
'
' Excel Interface to the SEOmoz Free API
' Written by Jason Green
' BusinessHut.com
' 4/18/2011 - Beta 1
' 9/22/2011 - Beta 2 - Changed to "on demand" function and added rate limiter.
'
' Verified in Excel 2007 and 2010 on Windows XP and Windows 7
' Does not work on Macs unless running a Windows OS on a VM
'
' Post your questions and suggestions for improvement at the URL below:
' http://www.businesshut.com/seo/using-seomoz-free-api-excel/
' To get your own API key, visit: www.seomoz.org/api   *There are both free and paid options.
'----------------------------------------------------------------------------------
MsgBox ("Please be patient and don't click anything. This will take about 1 second for each URL processed.")

Dim startTime
Dim endTime
Dim runTime
startTime = Now()

    ' Rate Limiter ' http://apiwiki.seomoz.org/w/page/13991144/Rate%20Limiting
    ' SEOMoz allows no more than 3 requests per second.

  Const WinHttpRequestOption_UserAgentString = 0
  Const WinHttpRequestOption_EnableRedirects = 6
  
  '***(Insert your info manually here to use the macro with any spreadsheet.)***
  Dim secretKey As String
    secretKey = Range("mysecretkey")  ' Your secret key
  Dim accessID As String
    accessID = Range("accessID") ' Your Member ID
  Dim timeStamp As Long
    timeStamp = Range("timestamp") ' Unix Timestamp
  Dim signature As String
    signature = URLEncode(Range("signature")) ' URL-encoded Signature
      
' Check for credentials
If Len(accessID) < 1 Then
MsgBox ("Please enter your LinkScape API credentials on the Credentials tab.")
End
End If


Dim myRow As Long
Dim myCol As Integer
Dim myLimit As Integer
Dim urlsRun As Long

' SEOmoz Result Variables
Dim httpStatus As String
Dim domainAuthority As String
Dim pageAuthority As String
Dim mozRank As String
Dim mozRankRaw As String
Dim subdomainMozRank As String
Dim subdomainMozRankRaw As String
Dim links As String
Dim externalLinks As String

On Error Resume Next
Application.DisplayAlerts = False
' *** If using as a stand alone macro, delete the 3 defaults below and uncomment the Input Boxes. ***
myCol = 1 'InputBox(Prompt:="Which column contains your data? (A=1, B=2, etc...)", Title:="Data Column", Default:=1)
myRow = 10 'InputBox(Prompt:="On which row does your data begin? (1=1, 2=2, etc...)  ;-)", Title:="Starting Row", Default:=2)
myLimit = 10 'InputBox(Prompt:="Do you want to limit the number of results? If no,(enter nothing), the process will continue until a blank row is found. Run time is about 100 URL's per minute.", Title:="Limit Results", Default:=0)
    If myLimit = 0 Or myLimit = vbNullString Then
        myLimit = 7200
    End If

Application.DisplayAlerts = True

urlsRun = 0

Do Until ActiveSheet.Cells(myRow, myCol) = "" Or urlsRun > myLimit   'Loop until a blank row is found or the limit is reached.

URL = ActiveSheet.Cells(myRow, myCol)

  ' Remove http:// from URL if exists.
  URL = Replace(URL, "http://", "")
  URL = Replace(URL, "https://", "")
   
' Pause if running too quickly: Adjust this number is running too slowly or if you receive blank responses. (an indication of going over the limit)
Sleep 100

  ' Build the seoMoz API URL
    seoMozURL = "http://lsapi.seomoz.com/linkscape/url-metrics/" & URL & "?AccessID=" & accessID & "&Expires=" & timeStamp & "&Signature=" & signature
          
    On Error Resume Next
       Set httpRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
         If httpRequest Is Nothing Then
            Set httpRequest = CreateObject("WinHttp.WinHttpRequest.5")
         End If
       Err.Clear
    On Error GoTo 0

    httpRequest.Option(WinHttpRequestOption_UserAgentString) = "Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 6.0)"
    httpRequest.Option(WinHttpRequestOption_EnableRedirects) = AllowRedirects
        
  'Clear any pervious web page source information
    PageSource = ""
    
          'Launch the HTTP httpRequest synchronously
            On Error Resume Next
              httpRequest.Open "POST", seoMozURL, False
              If Err.Number <> 0 Then
                'Handle connection errors
                  'GetURLmetrics = Err.Description
                  ActiveSheet.Cells(myRow, myCol + 1) = Err.Description
                  Err.Clear
                  Exit Sub
              End If
            On Error GoTo 0
           
          'Send the http httpRequest for server status
            On Error Resume Next
              httpRequest.Send
              httpRequest.WaitForResponse
              If Err.Number <> 0 Then
                ' Handle server errors
                  PageSource = "Error"
                  ActiveSheet.Cells(myRow, 2) = Err.Description & " - " & httpRequest.responsetext
                  Err.Clear
              Else
                'Show HTTP response info
                  'ActiveSheet.Cells(myRow, myCol + 1) = httpRequest.responsetext 'Save the web page text
                  
                  'httpStatus
                  httpStatus = Mid(httpRequest.responsetext, InStr(httpRequest.responsetext, Chr(34) & "us" & Chr(34)) + 5, 3)
                  If Len(httpStatus) < 1 Then
                    ActiveSheet.Cells(myRow, 2) = httpRequest.responsetext
                  Else
                    httpStatus = KillText(httpStatus)   'Run separate function to remove extra characters.
                    ActiveSheet.Cells(myRow, 2) = httpStatus
                  End If
                                   
                  
                  'domainAuthority
                  domainAuthority = Mid(httpRequest.responsetext, InStr(httpRequest.responsetext, Chr(34) & "pda" & Chr(34)) + 6, 5)
                  domainAuthority = KillText(domainAuthority)   'Run separate function to remove extra characters.
                  ActiveSheet.Cells(myRow, 3) = domainAuthority
                  
                  'pageAuthority
                  pageAuthority = Mid(httpRequest.responsetext, InStr(httpRequest.responsetext, Chr(34) & "upa" & Chr(34)) + 6, 5)
                  pageAuthority = KillText(pageAuthority)   'Run separate function to remove extra characters.
                  ActiveSheet.Cells(myRow, 4) = pageAuthority
              
                  'mozRank
                  mozRank = Mid(httpRequest.responsetext, InStr(httpRequest.responsetext, Chr(34) & "umrp" & Chr(34)) + 7, 4)
                  mozRank = KillText(mozRank)   'Run separate function to remove extra characters.
                  ActiveSheet.Cells(myRow, 5) = mozRank
                  
                  'mozRankRaw
                  mozRankRaw = Mid(httpRequest.responsetext, InStr(httpRequest.responsetext, Chr(34) & "umrr" & Chr(34)) + 7, 4)
                  mozRankRaw = KillText(mozRankRaw)   'Run separate function to remove extra characters.
                  ActiveSheet.Cells(myRow, 6) = mozRankRaw
              
                  'subdomainMozRank
                  subdomainMozRank = Mid(httpRequest.responsetext, InStr(httpRequest.responsetext, Chr(34) & "fmrp" & Chr(34)) + 7, 4)
                  subdomainMozRank = KillText(subdomainMozRank)   'Run separate function to remove extra characters.
                  ActiveSheet.Cells(myRow, 7) = subdomainMozRank
              
                  'subdomainMozRankRaw
                  subdomainMozRankRaw = Mid(httpRequest.responsetext, InStr(httpRequest.responsetext, Chr(34) & "fmrr" & Chr(34)) + 7, 4)
                  subdomainMozRankRaw = KillText(subdomainMozRankRaw)   'Run separate function to remove extra characters.
                  ActiveSheet.Cells(myRow, 8) = subdomainMozRankRaw
              
                  'links
                  links = Mid(httpRequest.responsetext, InStr(httpRequest.responsetext, Chr(34) & "uid" & Chr(34)) + 6, 9)
                  links = KillText(links)   'Run separate function to remove extra characters.
                  ActiveSheet.Cells(myRow, 9) = links
              
                  'externalLinks
                  externalLinks = Mid(httpRequest.responsetext, InStr(httpRequest.responsetext, Chr(34) & "ueid" & Chr(34)) + 7, 9)
                  externalLinks = KillText(externalLinks)   'Run separate function to remove extra characters.
                  ActiveSheet.Cells(myRow, 10) = externalLinks
              
              End If
            On Error GoTo 0
                   
        urlsRun = urlsRun + 1
        myRow = myRow + 1
  Loop
                     
  endTime = Now()
  runTime = DateDiff("s", startTime, endTime)
  MsgBox ("It took " & runTime & " seconds to process " & urlsRun & " URLs.")

  
End Sub
  


Public Function URLEncode( _
   StringToEncode As String, _
   Optional UsePlusRatherThanHexForSpace As Boolean = False _
) As String

  Dim TempAns As String
  Dim CurChr As Integer
  CurChr = 1

  Do Until CurChr - 1 = Len(StringToEncode)
    Select Case Asc(Mid(StringToEncode, CurChr, 1))
      Case 48 To 57, 65 To 90, 97 To 122
        TempAns = TempAns & Mid(StringToEncode, CurChr, 1)
      Case 32
        If UsePlusRatherThanHexForSpace = True Then
          TempAns = TempAns & "+"
        Else
          TempAns = TempAns & "%" & Hex(32)
        End If
      Case Else
        TempAns = TempAns & "%" & _
          Right("0" & Hex(Asc(Mid(StringToEncode, _
          CurChr, 1))), 2)
    End Select

    CurChr = CurChr + 1
  Loop

  URLEncode = TempAns
End Function

Function KillText(cellInput) As String
    For i = 1 To Len(cellInput)
        Select Case Mid(cellInput, i, 1)
            Case 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, "."
                Charval = Mid(cellInput, i, 1)
            Case Else
                Charval = ""
        End Select
    KillText = KillText & Charval
    Next i
        
End Function