As Last.Fm only returns the top 50 tracks for each artist, the track will either be given a rank from 1 to 50 or left blank. For my test library of 13k+ tracks, 77% were populated with a value. Because the data is cached for each artist, this process will generally speed up as it progresses, but there is a progress bar which shows the estimated time remaining.
As always, the installer is available to download from my website, the link to which is in my signature. And here is the code...
Code: Select all
'
' MediaMonkey Script
'
' NAME: ArtistTopTracks 1.5
'
' AUTHOR: trixmoto (http://trixmoto.net)
' DATE : 18/08/2012
'
' INSTALL: Copy to Scripts directory and add the following to Scripts.ini 
'          Don't forget to remove comments (') and set the order appropriately
'
' [ArtistTopTracks]
' FileName=ArtistTopTracks.vbs
' ProcName=ArtistTopTracks
' Order=50
' DisplayName=&Artist Top Tracks
' Description=Get popularity ranking from Last.Fm
' Language=VBScript
' ScriptType=0
'
' FIXES: Added option to show toolbar button
'
Option Explicit
Dim Debug : Debug = False
Dim Mode : Mode = 0
Dim Prefix : Prefix = ""
Dim Field : Field = ""
Dim Zeros : Zeros = 2
Dim Limit : Limit = 50
Dim Button : Button  = False
Sub Toolbar(but)
  Call ArtistTopTracks()
End Sub
Sub ArtistTopTracks
  Dim ini : Set ini = SDB.IniFile
  If ini.StringValue("ArtistTopTracks","Debug") = "" Then
    ini.BoolValue("ArtistTopTracks","Debug") = Debug 
  End If      
  If ini.StringValue("ArtistTopTracks","Mode") = "" Then
    ini.IntValue("ArtistTopTracks","Mode") = Mode
  End If
  If ini.StringValue("ArtistTopTracks","Zeros") = "" Then
    ini.IntValue("ArtistTopTracks","Zeros") = Zeros
  End If  
  If ini.StringValue("ArtistTopTracks","Limit") = "" Then
    ini.IntValue("ArtistTopTracks","Limit") = Limit
  End If   
  
  'get selected tracks
  Dim list : Set list = SDB.SelectedSongList 
  If list.count = 0 Then 
    Set list = SDB.AllVisibleSongList 
  End If 
  If list.count = 0 Then
    Call SDB.MessageBox("ArtistTopTracks: There are no selected tracks.",mtError,Array(mbOk))
    Exit Sub
  End If 
  
  Dim Form : Set Form = SDB.UI.NewForm
  Form.Common.SetRect 100, 100, 285, 260
  Form.BorderStyle  = 3   ' Non-Resizable
  Form.FormPosition = 4   ' Screen Center
  Form.SavePositionName = "ArtistTopTracksPos"
  Form.Caption = "ArtistTopTracks Options"
 
  Dim Label : Set Label = SDB.UI.NewLabel(Form)
  Label.Caption = "Field to use:"
  Label.Common.Left = 10
  Label.Common.Top = 15
 
  Dim EdtField : Set EdtField = SDB.UI.NewEdit(Form)
  EdtField.Common.ControlName = "ATTField"  
  EdtField.Common.Left = 92
  EdtField.Common.Top = Label.Common.Top -4
  EdtField.Text = ini.StringValue("ArtistTopTracks","Field") 
    
  Dim Label4 : Set Label4 = SDB.UI.NewLabel(Form)
  Label4.Caption = "Script mode:"
  Label4.Common.Left = 10
  Label4.Common.Top = Label.Common.Top +25
 
  Dim DrpMode : Set DrpMode = SDB.UI.NewDropdown(Form)
  DrpMode.Common.ControlName = "ATTMode"  
  DrpMode.Common.Left = 92
  DrpMode.Common.Top = Label4.Common.Top -4
  DrpMode.AddItem("Rank")    
  DrpMode.AddItem("Playcount")
  DrpMode.AddItem("Listeners")  
  DrpMode.AddItem("Rating")  
  DrpMode.ItemIndex = ini.IntValue("ArtistTopTracks","Mode") 
  DrpMode.Style = 2
    
  Dim Label5 : Set Label5 = SDB.UI.NewLabel(Form)
  Label5.Caption = "String prefix:"
  Label5.Common.Left = 10
  Label5.Common.Top = Label4.Common.Top +25
    
  Dim EdtPrefix : Set EdtPrefix = SDB.UI.NewEdit(Form)
  EdtPrefix.Common.ControlName = "ATTPrefix"  
  EdtPrefix.Common.Left = 92
  EdtPrefix.Common.Top = Label5.Common.Top -4
  EdtPrefix.Text = ini.StringValue("ArtistTopTracks","Prefix")
  
  Dim Label6 : Set Label6 = SDB.UI.NewLabel(Form)
  Label6.Caption = "Zero pad to:"
  Label6.Common.Left = 10
  Label6.Common.Top = Label5.Common.Top +25
    
  Dim SpnZeros : Set SpnZeros = SDB.UI.NewSpinEdit(Form)
  SpnZeros.Common.ControlName = "ATTZeros"  
  SpnZeros.Common.Left = 92
  SpnZeros.Common.Top = Label6.Common.Top -4
  SpnZeros.MinValue = 0
  SpnZeros.MaxValue = 99
  SpnZeros.Value = ini.IntValue("ArtistTopTracks","Zeros")
  Dim Label7 : Set Label7 = SDB.UI.NewLabel(Form)
  Label7.Caption = "Limit to top:"
  Label7.Common.Left = 10
  Label7.Common.Top = Label6.Common.Top +25
    
  Dim SpnLimit : Set SpnLimit = SDB.UI.NewSpinEdit(Form)
  SpnLimit.Common.ControlName = "ATTLimit"  
  SpnLimit.Common.Left = 92
  SpnLimit.Common.Top = Label7.Common.Top -4
  SpnLimit.MinValue = 0
  SpnLimit.MaxValue = 9999
  SpnLimit.Value = ini.IntValue("ArtistTopTracks","Limit")   
    
  Dim ChkDebug : Set ChkDebug = SDB.UI.NewCheckbox(Form)
  ChkDebug.Common.ControlName = "ATTDebug"  
  ChkDebug.Common.Left = 10
  ChkDebug.Common.Top = Label7.Common.Top +25
  ChkDebug.Common.Width = 165
  ChkDebug.Caption = "Create debug logfile?" 
  ChkDebug.Checked = ini.BoolValue("ArtistTopTracks","Debug")   
  Dim ChkButton : Set ChkButton = SDB.UI.NewCheckbox(Form)
  ChkButton.Common.ControlName = "ATTButton"  
  ChkButton.Common.Left = 10
  ChkButton.Common.Top = ChkDebug.Common.Top +25
  ChkButton.Common.Width = 165
  ChkButton.Caption = "Show toolbar button?" 
  ChkButton.Checked = ini.BoolValue("ArtistTopTracks","Button")  
   
  Dim BtnCancel : Set BtnCancel = SDB.UI.NewButton(Form)
  BtnCancel.Caption = "&Cancel"
  BtnCancel.Cancel = True
  BtnCancel.ModalResult = 2
  BtnCancel.Common.Left = Form.Common.Width - BtnCancel.Common.Width -22
  BtnCancel.Common.Top = ChkButton.Common.Top +25
 
  Dim BtnOk : Set BtnOk = SDB.UI.NewButton(Form)
  BtnOk.Caption = "&Ok"
  BtnOk.Default = True
  BtnOk.ModalResult = 1
  BtnOk.Common.Left = BtnCancel.Common.Left - BtnOk.Common.Width -10
  BtnOk.Common.Top = BtnCancel.Common.Top
  DrpMode.UseScript = Script.ScriptPath
  DrpMode.OnSelectFunc = "OnSelectMode" 
  Call OnSelectMode(DrpMode)  
 
  If Form.ShowModal = 1 Then
    Field = EdtField.Text
    Prefix = EdtPrefix.Text
    Debug = ChkDebug.Checked
    Mode = DrpMode.ItemIndex
    Zeros = SpnZeros.Value
	  Limit = SpnLimit.Value
    Button = ChkButton.Checked
    ini.StringValue("ArtistTopTracks","Field") = Field
    ini.StringValue("ArtistTopTracks","Prefix") = Prefix
    ini.BoolValue("ArtistTopTracks","Debug") = Debug
    ini.IntValue("ArtistTopTracks","Mode") = Mode
    ini.IntValue("ArtistTopTracks","Zeros") = Zeros
	  ini.IntValue("ArtistTopTracks","Limit") = Limit
    ini.BoolValue("ArtistTopTracks","Button") = Button
    SDB.Objects("ATT-Button").Visible = Button
  Else
    Button = ChkButton.Checked
    ini.BoolValue("ArtistTopTracks","Button") = Button
    SDB.Objects("ATT-Button").Visible = Button
    Exit Sub             
  End If
  
  'handle new mode
  If Mode = 3 Then
    Field = "Rating"
	  Prefix = ""
	  Zeros = 0
  End If  
  
  'check field name
  Dim temp : temp = ""
  If Field = "" Then
    Call SDB.MessageBox("ArtistTopTracks: No field name was specified.",mtError,Array(mbOk))
    Exit Sub
  Else
    On Error Resume Next
    Execute("temp = list.Item(0)."&Field)    
    If Err.Number <> 0 Then
      Err.Clear
      Call SDB.MessageBox("ArtistTopTracks: Invalid field name was specified.",mtError,Array(mbOk))
      Exit Sub
    End If
    If Not (Prefix = "") Then
      Execute("list.Item(0)."&Field&" = """"")
      If Err.Number <> 0 Then
        Err.Clear
        Call SDB.MessageBox("ArtistTopTracks: Numeric field was specified so prefix will be ignored.",mtInformation,Array(mbOk))
        Prefix = ""
      Else
        Execute("list.Item(0)."&Field&" = temp")
      End If
    End If    
    On Error Goto 0
  End If    
  'create progress bar
  Set SDB.Objects("ATT-Data") = SDB.NewSongData
  Dim prog : Set prog = SDB.Progress
  prog.Value = 0
  prog.MaxValue = list.Count
  prog.Text = "ArtistTopTracks: Initialising..."
  SDB.ProcessMessages
  If Debug Then
    Call clear()
    Call out("Processing "&list.Count&" tracks...")
  End If    
  
  'process tracks
  Dim beg : beg = Timer
  Dim num : num = 0
  Dim url : url = "http://ws.audioscrobbler.com/2.0/?method=artist.getTopTracks&limit="&Limit&"&api_key=6cfe51c9bf7e77d6449e63ac0db2ac24&artist="
  Dim cac : Set cac = CreateObject("Scripting.Dictionary")
  Dim dic : Set dic = CreateObject("Scripting.Dictionary")
  Dim k : k = 0  
  For k = 0 To list.Count-1
    Dim itm : Set itm = list.Item(k)
    Dim str : str = ""
    If k > 0 And list.Count > 3 Then
      Dim dif : dif = Timer-beg
      If dif < 0 Then
        dif = dif+86400
      End If      
      Dim sec : sec = (dif*list.Count/(k+1))-dif
      If num > 0 Then
        num = ((sec*.55)+(num*.45))
      Else
        num = sec
      End If
      Dim m : m = num\60 
      Dim h : h = m\60  
      Dim s : s = num Mod 60
      m = (m Mod 60)
      If h > 0 Then
        If h > 1 Then
          str = h&" hours and "
        Else
          str = "1 hour and "
        End If
        If m = 1 Then
          str = str&"1 minute"
        Else
          str = str&m&" minutes"
        End If
      Else
        If m > 0 Then
          If m > 1 Then
            str = m&" minutes and "
          Else
            str = "1 minute and "
          End If    
        End If
        If s > 0 Then
          If s = 1 Then    
            str = str&"1 second"
          Else
            str = str&s&" seconds"
          End If
        End If
      End If 
      str = " (time remaining: "&str&")"
    End If 
    str = "Processing track "&(k+1)&" of "&(list.Count)&str&"..."
    If Debug Then
      Call out(str)
    End If
    prog.Text = "ArtistTopTracks: "&str
    SDB.ProcessMessages
    
    'populate cache
    Dim ttl : ttl = ""
    Dim art : art = UCase(itm.ArtistName)
    If InStr(art,";") > 0 Then
      art = Left(art,InStr(art,";")-1)
    End If        
    art = FixPrefixes(art)
    If cac.Exists(art) Then
      If Debug Then
        Call out("Using '"&art&"' data from cache...")
      End If    
    Else
      str = url&EncodeUrl(art)
      If Debug Then
        Call out("Query for '"&art&"' data...")
        Call out("@"&str)
      End If
      Dim xml : Set xml = CreateObject("Microsoft.XMLHTTP")      
      Call xml.open("GET",str,true)
      Call xml.send()  
      Dim cnt : cnt = 0
      While (xml.readyState < 4) And (cnt < 300)
        Call SDB.Tools.Sleep(100)
        SDB.ProcessMessages
        cnt = cnt+1
        If prog.Terminate Then
          cnt = 300
        End If    
      WEnd
      If xml.readyState = 4 Then
        str = xml.responseText
        If InStr(str,"<lfm status=""ok"">") > 0 Then          
          Set xml = CreateObject("Microsoft.XMLDOM")
          xml.LoadXML(str)
          Set dic = CreateObject("Scripting.Dictionary")
          Dim ele : Set ele = Nothing
          For Each ele In xml.getElementsByTagName("track")
            Select Case Mode
              Case 1
                str = ele.getElementsByTagName("playcount").Item(0).Text
              Case 2
                str = ele.getElementsByTagName("listeners").Item(0).Text
              Case Else    
                str = ele.getAttribute("rank")
            End Select
            If Not (str = "") Then
              ttl = StripName(ele.getElementsByTagName("name").Item(0).Text)
              If Not (ttl = "") Then
                If Debug Then
                  Call out(str&". "&ttl)
                End If
                If Not (dic.Exists(ttl)) Then
                  dic.Item(ttl) = str
                End If
              End If
            End If
          Next
          Call cac.Add(art,dic)          
        End If
      End If
    End If    
    
    'set track rank
    If cac.Exists(art) Then
      Set dic = cac.Item(art)
      ttl = StripName(itm.Title)       
      If dic.Exists(ttl) Then
        Dim rank : rank = CLng(dic.Item(ttl))
        If rank > 0 Then
          On Error Resume Next
          Execute("temp = itm."&Field)    
          If Err.Number <> 0 Then
            Err.Clear
          Else
            Dim boo : boo = False		  
            Dim valu : valu = ""
			If Mode = 3 Then
			  valu = ValueToRating(rank)
              If Not (temp = valu) Then
                boo = True
              End If			  
			Else
			  valu = Prefix&Pad(rank,Zeros)
              If Prefix = "" Then
                If Not (temp = rank) Then
                  boo = True
                End If
              Else
                If Not (temp = valu) Then
                  boo = True
                End If
			  End If				
            End If
            If boo Then
              If Debug Then
                Call out(itm.Title&" ("&itm.ArtistName&") = "&rank)
              End If        
              Execute("itm."&Field&" = valu")
              SDB.Database.BeginTransaction
              Dim lst : Set lst = SDB.NewSongList
              Call lst.Add(itm)
              Call lst.UpdateAll()
              SDB.Database.Commit              
            End If
          End If
          On Error Goto 0        
        End If
      End If
    End If  
    'continue looping
    Call SDB.Tools.Sleep(200)
    prog.Increase
    SDB.ProcessMessages
    If prog.Terminate Then
      Set SDB.Objects("ATT-Data") = Nothing 
      Exit Sub
    End If
  Next
  Set SDB.Objects("ATT-Data") = Nothing     
End Sub
Sub Install()
  Dim inip : inip = SDB.ApplicationPath&"Scripts\Scripts.ini"
  Dim inif : Set inif = SDB.Tools.IniFileByPath(inip)
  If Not (inif Is Nothing) Then
    inif.StringValue("ArtistTopTracks","Filename") = "ArtistTopTracks.vbs"
    inif.StringValue("ArtistTopTracks","Procname") = "ArtistTopTracks"
    inif.StringValue("ArtistTopTracks","Order") = "50"
    inif.StringValue("ArtistTopTracks","DisplayName") = "&Artist Top Tracks"
    inif.StringValue("ArtistTopTracks","Description") = "Get popularity ranking from Last.Fm"
    inif.StringValue("ArtistTopTracks","Language") = "VBScript"
    inif.StringValue("ArtistTopTracks","ScriptType") = "0"
    SDB.RefreshScriptItems
  End If
  
  Dim but : Set but = SDB.Objects("ATT-Button")
  If but Is Nothing Then
    Set but = SDB.UI.AddMenuItem(SDB.UI.Menu_TbStandard,0,0)
    but.Caption = "Artist Top Tracks"
    but.IconIndex = SDB.RegisterIcon("Scripts\ATT.ico",0)
    but.UseScript = SDB.ApplicationPath&"Scripts\ArtistTopTracks.vbs"
    but.OnClickFunc = "Toolbar"
    but.Visible = SDB.IniFile.BoolValue("ArtistTopTracks","Toolbar") 
    Set SDB.Objects("ATT-Button") = but
  End If  
End Sub
Function FixPrefixes(str)
  FixPrefixes = str
  Dim list : list = ""
  If SDB.IniFile.BoolValue("Options","IgnoreTHEs") Then
    list = SDB.IniFile.StringValue("Options","IgnoreTHEStrings")
  End If
  If Not (list = "") Then   
    Dim i : i = 0
    Dim a : a = Split(list,",")
    For i = 0 To UBound(a)
      Dim s : s = Trim(a(i))
      Dim l : l = Len(s)+3
      If UCase(Right(FixPrefixes,l)) = " ("&UCase(s)&")" Then
        FixPrefixes = s&" "&Left(FixPrefixes,Len(FixPrefixes)-l)  
        Exit For      
      End If
      l = Len(s)+2
      If UCase(Right(FixPrefixes,l)) = ", "&UCase(s) Then
        FixPrefixes = s&" "&Left(FixPrefixes,Len(FixPrefixes)-l)  
        Exit For      
      End If        
    Next
  End If
End Function
Function EncodeUrl(sRawURL)
  Const sValidChars = "1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\/:"
  Dim url : url = Replace(sRawURL,"+","%2B")
  If Len(url) > 0 Then
    Dim i : i = 1
    Do While i < Len(url)+1
      Dim s : s = Mid(url,i,1)
      If InStr(1,sValidChars,s,0) = 0 Then
        Dim d : d = AscW(s)
        If d < 0 Then
          d = d+65536
        End If      
        If d = 32 Or d > 65535 Then
          s = "+"
        Else
          If d < 128 Then
            s = DecToHex(d)
          ElseIf d < 2048 Then
            s = DecToUtf2(d)
          Else
            s = DecToUtf3(d)
          End If
        End If
      Else
        Select Case s
          Case "&"
            s = "%2526"
          Case "/"
            s = "%252F"
          Case "\"
            s = "%5C"
          Case ":"
            s = "%3A"
        End Select
      End If
      EncodeUrl = EncodeUrl&s
      i = i+1
    Loop
  End If
End Function
Function HexToDec(h)
  HexToDec = 0
  Dim i : i = 0
  For i = Len(h) To 1 Step -1
    Dim d : d = Mid(h,i,1)
    d = Instr("0123456789ABCDEF",UCase(d))-1
    If d >= 0 Then
      HexToDec = HexToDec+(d*(16^(Len(h)-i)))
    Else
      HexToDec = 0
      Exit For
    End If
  Next
End Function
Function DecToBin(intDec,e)
  DecToBin = ""
  Dim d : d = intDec
  While e >= 1
    If d >= e Then
      d = d - e
      DecToBin = DecToBin&"1"
    Else
      DecToBin = DecToBin&"0"
    End If
    e = e / 2
  Wend
End Function
Function BinToHex(strBin)
  Dim d : d = 0
  Dim i : i = 0
  For i = Len(strBin) To 1 Step -1
    Select Case Mid(strBin,i,1)
      Case "0"
        'do nothing
      Case "1"
        d = d + (2^(Len(strBin)-i))
      Case Else
        BinToHex = "00"
        Exit Function
    End Select
  Next
  BinToHex = DecToHex(d)
End Function
Function DecToHex(d)
  If d < 16 Then
    DecToHex = "%0"&CStr(Hex(d))
  Else
    DecToHex = "%"&CStr(Hex(d))
  End If
End Function
Function DecToUtf2(d)
  Dim b : b = DecToBin(d,1024)
  Dim a : a = "110"&Left(b,5)
  b = "10"&Mid(b,6)
  DecToUtf2 = BinToHex(a)&BinToHex(b)
End Function 
Function DecToUtf3(d)
  Dim b : b = DecToBin(d,32768)
  Dim a : a = "1110"&Left(b,4)
  Dim c : c = "10"&Mid(b,11,6)
  b = "10"&Mid(b,5,6)
  DecToUtf3 = BinToHex(a)&BinToHex(b)&BinToHex(c)
End Function 
Function DecToUtf4(d)
  Dim b : b = DecToBin(d,557056)
  Dim a : a = "11110"&Left(b,3)
  Dim c : c = "10"&Mid(b,10,6)
  Dim e : e = "10"&Mid(b,16,6)
  b = "10"&Mid(b,4,6)
  DecToUtf4 = BinToHex(a)&BinToHex(b)&BinToHex(c)&BinToHex(e)
End Function
Function StripName(nam)
  StripName = ""
  If nam = "" Then
    Exit Function
  End If
  Dim i : i = 0
  Dim s : s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ÅÄÂÃÁÀÆËÊÉÈÏÎÍÌÖÔÕÓÒØÜÛÚÙÝÇÐÑß "
  Dim t : t = UCase(nam)
  t = Replace(t,"&"," AND ")
  t = Replace(t,"+"," AND ")
  t = Replace(t," N "," AND ")
  t = Replace(t,"'N'"," AND ")  
  For i = 1 To Len(t)
    Dim c : c = Mid(t,i,1)
    If InStr(s,c) > 0 Then
      StripName = StripName&c
    End If
  Next
  StripName = Replace(StripName,"  "," ")
End Function
Sub clear()
  Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
  Dim loc : loc = SDB.TemporaryFolder
  If Right(loc,1) = "\" Then
    loc = loc&"ArtistTopTracks.log"
  Else
    loc = loc&"\ArtistTopTracks.log"
  End If
  Dim logf : Set logf = fso.CreateTextFile(loc,True)
  Call logf.Close()
End Sub
Sub out(txt)
  Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
  Dim loc : loc = SDB.TemporaryFolder
  If Right(loc,1) = "\" Then
    loc = loc&"ArtistTopTracks.log"
  Else
    loc = loc&"\ArtistTopTracks.log"
  End If  
  Dim logf : Set logf = fso.OpenTextFile(loc,8,True)
  Call logf.WriteLine(Time&" "&SDB.ToAscii(txt))
  Call logf.Close()
End Sub
Function Pad(val,num)
  Pad = ""&val
  While Len(Pad) < num
    Pad = "0"&Pad
  WEnd
End Function
Sub OnSelectMode(DrpMode)
  Dim top : Set top = DrpMode.Common.TopParent.Common
  Dim EdtField : Set EdtField = top.ChildControl("ATTField")
  Dim EdtPrefix : Set EdtPrefix = top.ChildControl("ATTPrefix")
  Dim SpnZeros : Set SpnZeros = top.ChildControl("ATTZeros")
  If DrpMode.ItemIndex = 3 Then
    EdtField.Common.Enabled = False
	EdtPrefix.Common.Enabled = False
	SpnZeros.Common.Enabled = False
  Else
    EdtField.Common.Enabled = True
	EdtPrefix.Common.Enabled = True
	SpnZeros.Common.Enabled = True
  End If
End Sub
Function ValueToRating(val)
  Dim temp : temp = ((100*Limit)/(Limit-1))-((100*val)/(Limit-1))
  If (temp < 0) Or (temp > 100) Then
    ValueToRating = -1
    Exit Function
  End If 
  ValueToRating = 0
  If (temp > -1) And (temp < 6) Then
    Exit Function
  End If   
  While temp > 15
    ValueToRating = ValueToRating+20
    temp = temp-20
  WEnd
  If temp > 5 Then
    ValueToRating = ValueToRating+10
  End If
End Function
