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