The installer can be downloaded from my website.
Code: Select all
'
' MediaMonkey Script
'
' NAME: DiscographyReport 2.1
'
' AUTHOR: trixmoto (http://trixmoto.net)
' DATE : 17/02/2011
'
' INSTALL: Copy to Scripts directory and add the following to Scripts.ini
' Don't forget to remove comments (') and set the order appropriately
'
' [DiscographyReport]
' FileName=DiscographyReport.vbs
' ProcName=DiscographyReport
' Order=50
' DisplayName=&Discography Report
' Description=Lists missing albums of selected artists
' Language=VBScript
' ScriptType=1
'
' FIXES: Fixed Last.fm not handling errors correctly
' Added better artist name fuzzy matching
'
Option Explicit
Dim AppTitle : AppTitle = "Discography Report 2.1"
Dim MaxAlbums : MaxAlbums = 0 'o=unlimited
Dim ImageSize : ImageSize = 65 'pixels
Dim ImageMode : ImageMode = 0 '0=large 1=medium 2=small
Dim ExtraInfo : ExtraInfo = False
Dim TheSource : TheSource = 0 '0=lastfm 1=discogs
Dim Debug : Debug = False
Sub DiscographyReport
'check not already running
Dim list : Set list = SDB.Objects("DiscographyReportList")
If Not (list Is Nothing) Then
Exit Sub
End If
'get selected tracks
Set list = SDB.SelectedSongList
If list.Count = 0 Then
Set list = SDB.AllVisibleSongList
If list.Count = 0 Then
Call SDB.MessageBox("DiscographyReport: There are no selected tracks to process.",mtError,Array(mbOk))
Exit Sub
End If
End If
'get selected artists
Dim data : Set data = CreateObject("Scripting.Dictionary")
Dim i : i = 0
For i = 0 To list.Count-1
Dim itm : Set itm = list.Item(i)
Dim a : a = Split(itm.ArtistName,";")
Dim j : j = 0
For j = 0 To UBound(a)
data.Item(Trim(a(j))) = ""
Next
Next
Set SDB.Objects("DiscographyReportItem") = list.Item(0)
Set list = SDB.NewSongList
If data.Count > 1 Then
Call SortData(data)
End If
Dim tot : tot = data.Count
Set SDB.Objects("DiscographyReportList") = list
Set SDB.Objects("DiscographyReportData") = data
'set progress bar
Dim prog : Set prog = SDB.Progress
prog.Text = "DiscographyReport: Initialising script..."
prog.Value = 0
prog.MaxValue = tot
SDB.ProcessMessages
Set SDB.Objects("DiscographyReportProgress") = prog
'create debug logfile
If Debug Then
Call clear()
Call out(AppTitle)
Call out("Artists="&tot)
End If
'get options
Dim ini : Set ini = SDB.IniFile
If Not (ini.StringValue("DiscographyReport","MaxAlbums") = "") Then
MaxAlbums = ini.IntValue("DiscographyReport","MaxAlbums")
End If
If Not (ini.StringValue("DiscographyReport","ImageSize") = "") Then
ImageSize = ini.IntValue("DiscographyReport","ImageSize")
End If
If Not (ini.StringValue("DiscographyReport","ImageMode") = "") Then
ImageMode = ini.IntValue("DiscographyReport","ImageMode")
End If
If Not (ini.StringValue("DiscographyReport","ExtraInfo") = "") Then
ExtraInfo = ini.BoolValue("DiscographyReport","ExtraInfo")
End If
If Not (ini.StringValue("DiscographyReport","TheSource") = "") Then
TheSource = ini.IntValue("DiscographyReport","TheSource")
End If
'create confirmation
Dim Form : Set Form = SDB.UI.NewForm
Form.Common.SetRect 100, 100, 300, 230
Form.BorderStyle = 3
Form.FormPosition = 4
Form.SavePositionName = "DiscographyReportPos"
Form.Caption = AppTitle
Dim Label : Set Label = SDB.UI.NewLabel(Form)
Label.Caption = "Create report of albums for "&tot&" selected artists..."
Label.Common.Left = 10
Label.Common.Top = 10
Dim Label5 : Set Label5 = SDB.UI.NewLabel(Form)
Label5.Caption = "Album data source:"
Label5.Common.Left = 10
Label5.Common.Top = 35
Dim EdtSrc : Set EdtSrc = SDB.UI.NewDropdown(Form)
EdtSrc.Common.Left = 150
EdtSrc.Common.Top = 32
EdtSrc.AddItem("Last.fm")
EdtSrc.AddItem("Discogs.com")
EdtSrc.Style = 2
EdtSrc.ItemIndex = TheSource
Dim Label2 : Set Label2 = SDB.UI.NewLabel(Form)
Label2.Caption = "Maximum albums per artist:"
Label2.Common.Left = 10
Label2.Common.Top = 60
Dim EdtMax : Set EdtMax = SDB.UI.NewSpinEdit(Form)
EdtMax.Common.Left = 150
EdtMax.Common.Top = 57
EdtMax.Common.Hint = "0 = Unlimited"
EdtMax.MinValue = 0
EdtMax.MaxValue = 999
EdtMax.Value = MaxAlbums
Dim Label3 : Set Label3 = SDB.UI.NewLabel(Form)
Label3.Caption = "Image size (pixels):"
Label3.Common.Left = 10
Label3.Common.Top = 85
Dim EdtSiz : Set EdtSiz = SDB.UI.NewSpinEdit(Form)
EdtSiz.Common.Left = 150
EdtSiz.Common.Top = 82
EdtSiz.MinValue = 10
EdtSiz.MaxValue = 999
EdtSiz.Value = ImageSize
Dim Label4 : Set Label4 = SDB.UI.NewLabel(Form)
Label4.Caption = "Image source:"
Label4.Common.Left = 10
Label4.Common.Top = 110
Dim EdtMod : Set EdtMod = SDB.UI.NewDropdown(Form)
EdtMod.Common.Left = 150
EdtMod.Common.Top = 107
EdtMod.AddItem("Large")
EdtMod.AddItem("Medium")
EdtMod.AddItem("Small")
EdtMod.Style = 2
EdtMod.ItemIndex = ImageMode
Dim EdtExt : Set EdtExt = SDB.UI.NewCheckbox(Form)
EdtExt.Common.Left = 10
EdtExt.Common.Top = 135
EdtExt.Common.Width = 250
EdtExt.Caption = "Display extra album information?"
EdtExt.Checked = ExtraInfo
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 -25
BtnCancel.Common.Top = EdtExt.Common.Top + EdtExt.Common.Height +5
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
'show confirmation screen
If Not (Form.ShowModal = 1) Then
Set SDB.Objects("DiscographyReportList") = Nothing
Set SDB.Objects("DiscographyReportProgress") = Nothing
Set SDB.Objects("DiscographyReportData") = Nothing
Exit Sub
End If
'save settings
MaxAlbums = EdtMax.Value
ini.IntValue("DiscographyReport","MaxAlbums") = MaxAlbums
ImageSize = EdtSiz.Value
ini.IntValue("DiscographyReport","ImageSize") = ImageSize
ImageMode = EdtMod.ItemIndex
ini.IntValue("DiscographyReport","ImageMode") = ImageMode
ExtraInfo = EdtExt.Checked
ini.BoolValue("DiscographyReport","ExtraInfo") = ExtraInfo
TheSource = EdtSrc.ItemIndex
ini.IntValue("DiscographyReport","TheSource") = TheSource
'update debug logfile
If Debug Then
Call out("MaxAlbums="&MaxAlbums)
Call out("ImageSize="&ImageSize)
Call out("ImageMode="&ImageMode)
Call out("ExtraInfo="&ExtraInfo)
Call out("TheSource="&TheSource)
End If
'create queue
Dim que : Set que = CreateObject("Scripting.Dictionary")
que.Item("beg") = Timer
que.Item("lst") = Timer-1
que.Item("sts") = "READY"
que.Item("cur") = 0
que.Item("max") = tot
If ExtraInfo Then
que.Item("nxt") = 0
End If
Set SDB.Objects("DiscographyReportQueue") = que
'set controller
Dim tmr : Set tmr = SDB.CreateTimer(250)
Set SDB.Objects("DiscographyReportTimer1") = tmr
Call Script.RegisterEvent(tmr,"OnTimer","Controller")
End Sub
Sub Controller(tmr)
'get progress
Dim prog : Set prog = SDB.Objects("DiscographyReportProgress")
If prog Is Nothing Then
Call ClearUp("Sorry, the progress bar has been lost.",mtError)
Exit Sub
End If
'check cancelled
If prog.Terminate Then
Call ClearUp("Process cancelled by user.",mtInformation)
Exit Sub
End If
'get queue
Dim que : Set que = SDB.Objects("DiscographyReportQueue")
If que Is Nothing Then
Call ClearUp("Sorry, the queue has been lost.",mtError)
Exit Sub
End If
'check status
Select Case que.Item("sts")
Case "READY"
'continue
Case "DONE"
'continue
Case "BUSY"
'check xml
Dim xml2 : Set xml2 = SDB.Objects("DiscographyReportXML")
If xml2 Is Nothing Then
Call ClearUp("Sorry, the xml object has been lost.",mtError)
Exit Sub
End If
'check item
Dim itm2 : Set itm2 = SDB.Objects("DiscographyReportItem")
If itm2 Is Nothing Then
Call ClearUp("Sorry, the item has been lost.",mtError)
End If
Exit Sub
Case "EXIT"
Call ClearUp("Process cancelled by user.",mtInformation)
Exit Sub
Case Else
Call ClearUp("Sorry, unknown status '"&que.Item("sts")&"'.",mtError)
Exit Sub
End Select
'check items left
ExtraInfo = SDB.IniFile.BoolValue("DiscographyReport","ExtraInfo")
Dim cur : cur = Int(que.Item("cur"))
Dim max : max = Int(que.Item("max"))
If cur >= max Then
If (ExtraInfo = False) Or (que.Item("sts") = "DONE") Or (que.Item("nxt") = "0") Then
Call Script.UnregisterEvents(tmr)
prog.Value = prog.MaxValue
prog.Text = "DiscographyReport: Finalising..."
Call ShowReport()
Exit Sub
End If
End If
'check last query time
If Timer < (que.Item("lst")+1) Then
Exit Sub
End If
'check extra info
If (ExtraInfo) And (cur >= max) Then
que.Item("sts") = "BUSY"
que.Item("lst") = Timer
'first time
Dim nxt : nxt = Int(que.Item("nxt"))
If cur = max Then
prog.MaxValue = max+nxt
prog.Text = "DiscographyReport: Extra information..."
prog.Value = max
SDB.ProcessMessages
que.Item("cur") = cur+1
que.Item("tot") = nxt
nxt = 0
End If
'process next
nxt = nxt + 1
que.Item("nxt") = nxt
Dim arr : arr = Split(que.Item("~"&nxt),":|:")
prog.Text = "DiscographyReport: Processing album '"&arr(1)&"' ("&nxt&"/"&que.Item("tot")&")..."
prog.Value = max+nxt-1
SDB.ProcessMessages
'send query
Dim xml3 : Set xml3 = CreateObject("Microsoft.XMLHTTP")
Dim url3 : url3 = ""
Select Case TheSource
Case 0
url3 = "http://ws.audioscrobbler.com/2.0/?method=album.getInfo&artist="&fixurl(arr(0))&"&album="&fixurl(arr(1))&"&api_key=6cfe51c9bf7e77d6449e63ac0db2ac24"
Case 1
url3 = "http://www.discogs.com/release/"&fixurl(arr(3))&"?f=xml&api_key=8dc0e2d488"
End Select
If Debug Then
Call out("@"&url3)
End If
Call xml3.open("GET",url3,true)
Call xml3.Send()
Set SDB.Objects("DiscographyReportXML") = xml3
Dim res2 : Set res2 = SDB.CreateTimer(100)
Set SDB.Objects("DiscographyReportTimer2") = res2
Call Script.RegisterEvent(res2,"OnTimer","Response2")
Exit Sub
End If
'update queue
cur = cur + 1
que.Item("sts") = "BUSY"
que.Item("lst") = Timer
que.Item("cur") = cur
'check list
Dim list : Set list = SDB.Objects("DiscographyReportList")
If list Is Nothing Then
Call ClearUp("Sorry, the list has been lost.",mtError)
Exit Sub
End If
'check item
Dim itm : Set itm = Nothing
Dim data : Set data = SDB.Objects("DiscographyReportData")
Dim a : a = data.Keys
Dim nam : nam = a(cur-1)
'update progress
prog.Text = "DiscographyReport: Processing artist '"&nam&"' ("&cur&"/"&max&")..."
prog.Value = cur-1
SDB.ProcessMessages
'send query to last.fm
Dim str : str = ""
Select Case TheSource
Case 0
str = "http://ws.audioscrobbler.com/2.0/?method=artist.getTopAlbums&artist="&fixurl(nam)&"&api_key=6cfe51c9bf7e77d6449e63ac0db2ac24"
Case 1
str = "http://www.discogs.com/artist/"&fixurl(nam)&"?f=xml&api_key=8dc0e2d488"
End Select
If Debug Then
Call out("@"&str)
End If
Dim xml : Set xml = CreateObject("Microsoft.XMLHTTP")
Call xml.open("GET",str,true)
Call xml.Send()
Set SDB.Objects("DiscographyReportXML") = xml
'wait for response
Dim res : Set res = SDB.CreateTimer(100)
Set SDB.Objects("DiscographyReportTimer2") = res
Call Script.RegisterEvent(res,"OnTimer","Response")
End Sub
Sub Response(tmr)
'get query
Dim xml : Set xml = SDB.Objects("DiscographyReportXML")
If xml Is Nothing Then
Call Script.UnregisterEvents(tmr)
Exit Sub
End If
'check status
If Not (xml.readyState = 4) Then
Exit Sub
End If
Call Script.UnregisterEvents(tmr)
'load xml
Dim str : str = xml.responseText
Dim tag : tag = ""
Select Case TheSource
Case 0
Set xml = LoadLastFmXML(str)
tag = "album"
Case 1
Set xml = LoadDiscogsXML(str)
tag = "release"
Case Else
Set xml = Nothing
End Select
'get queue
Dim que : Set que = SDB.Objects("DiscographyReportQueue")
If que Is Nothing Then
Exit Sub
End If
'get item
Dim itm : Set itm = Nothing
Dim data : Set data = SDB.Objects("DiscographyReportData")
Dim a : a = data.Keys
Dim cur : cur = Int(que.Item("cur"))
Dim nam : nam = a(cur-1)
'get item ID
Dim itmID : itmID = 0
Dim sql : sql = "SELECT Id FROM Artists WHERE Artist='"&fixsqlart(nam)&"'"
If Debug Then
Call out("#"&sql)
End If
Dim iter : Set iter = SDB.Database.OpenSQL(sql)
If Not (iter.EOF) Then
itmID = iter.ValueByIndex(0)
End If
Set iter = Nothing
If xml Is Nothing Then
que.Item("#"&itmID) = ""
que.Item("sts") = "READY"
Exit Sub
End If
'get options
Dim ini : Set ini = SDB.IniFile
MaxAlbums = ini.IntValue("DiscographyReport","MaxAlbums")
ImageSize = ini.IntValue("DiscographyReport","ImageSize")
ImageMode = ini.IntValue("DiscographyReport","ImageMode")
ExtraInfo = ini.BoolValue("DiscographyReport","ExtraInfo")
'get results
Dim dic : Set dic = CreateObject("Scripting.Dictionary")
Dim ele,alb,img,elc,art,nxt,upa,rel
str = ""
cur = 0
For Each ele in xml.getElementsByTagName(tag)
alb = ele.ChildNodes.Item(0).Text
upa = StripName(alb)
If Not (dic.Exists(upa)) Then
dic.Item(upa) = ""
upa = fixsqlalb(alb)
sql = "SELECT Count(*) FROM Albums,ArtistsAlbums WHERE ArtistsAlbums.IDArtist="&itmID
sql = sql&" AND ArtistsAlbums.IDAlbum=Albums.ID AND (Albums.Album LIKE '"&upa&"')"
If Debug Then
Call out("#"&sql)
End If
If SDB.Database.OpenSQL(sql).ValueByIndex(0) = 0 Then
upa = Replace(upa,"Albums.Album","Songs.Album")
sql = "SELECT Count(*) FROM Songs,ArtistsSongs WHERE ArtistsSongs.IDArtist="&itmID
sql = sql&" AND ArtistsSongs.IDSong=Songs.ID AND (Songs.Album LIKE '"&upa&"')"
If Debug Then
Call out("#"&sql)
End If
If SDB.Database.OpenSQL(sql).ValueByIndex(0) = 0 Then
img = ""
Select Case TheSource
Case 0
art = ele.ChildNodes.Item(3).Text
img = ele.getElementsByTagName("image").Item(2-ImageMode).Text
rel = ""
Case 1
art = ""
img = "*@@*"
rel = ele.getAttribute("id")
End Select
If img = "" Then
img = "http://trixmoto.net/files/none.jpg"
End If
str = str&"<table style='padding-top:8px;' cellpadding='3' cellspacing='0'><tr>"
str = str&"<td width='40px'> </td><td style='margin:0;padding:0;padding-right:10px;vertical-align:top;'>"
str = str&"<img style='border:1px solid black;' src='"&img&"' width='"&ImageSize&"' height='"&ImageSize&"'/></td>"
str = str&"<td align='left' valign='top'><span style='font-size:1.1em;font-weight:bold;'>"
str = str&alb&"</span><br/><div>"
If Not (art = "") Then
str = str&"<a href="""&art&""" target=""_blank"">"&SDB.Localize("More information")&"</a>"
End If
If ExtraInfo Then
If art = "" Then
art = nam
Else
art = Left(art,InStrRev(art,"/")-1)
art = Mid(art,InStrRev(art,"/")+1)
art = Replace(art,"+"," ")
End If
nxt = Int(que.Item("nxt"))+1
str = Replace(str,"*@@*","*@"&nxt&"@*",1,1)&"</div><div>**"&nxt&"**</div></td></tr></table>"
que.Item("~"&nxt) = art&":|:"&alb&":|:"&itmID&":|:"&rel
que.Item("nxt") = nxt
Else
str = str&"</div></td></tr></table>"
End If
cur = cur + 1
If cur = MaxAlbums Then
Exit For
End If
End If
End If
Set iter = Nothing
End If
Next
'finished
que.Item("#"&itmID) = str
que.Item("sts") = "READY"
End Sub
Sub Response2(tmr)
'get query
Dim xml : Set xml = SDB.Objects("DiscographyReportXML")
If xml Is Nothing Then
Call Script.UnregisterEvents(tmr)
Exit Sub
End If
'check status
If Not (xml.readyState = 4) Then
Exit Sub
End If
Call Script.UnregisterEvents(tmr)
'load xml
Dim str : str = xml.responseText
Select Case TheSource
Case 0
Set xml = LoadLastFmXML(str)
Case 1
Set xml = LoadDiscogsXML(str)
Case Else
Set xml = Nothing
End Select
'get queue
Dim que : Set que = SDB.Objects("DiscographyReportQueue")
If que Is Nothing Then
Exit Sub
End If
'get item
Dim nxt : nxt = Int(que.Item("nxt"))
Dim arr : arr = Split(que.Item("~"&nxt),":|:")
'check results
If xml Is Nothing Then
Call que.Remove("~"&nxt)
que.Item("#"&arr(2)) = Replace(que.Item("#"&arr(2)),"**"&nxt&"**","",1,1)
If que.Item("nxt") = que.Item("tot") Then
que.Item("sts") = "DONE"
Else
que.Item("sts") = "READY"
End If
Exit Sub
End If
'get results
Dim ele,rel,cur,inf,gen,sty,img
Select Case TheSource
Case 0
For Each ele In xml.getElementsByTagName("releasedate")
rel = ele.Text
If InStrRev(rel,",") > 0 Then
rel = Left(rel,InStrRev(rel,",")-1)
End If
Next
Case 1
For Each ele In xml.getElementsByTagName("released")
rel = Replace(ele.Text,"-00-00","")
Next
For Each ele In xml.getElementsByTagName("genre")
If gen = "" Then
gen = ele.Text
Else
gen = gen&", "&ele.Text
End If
Next
For Each ele In xml.getElementsByTagName("style")
If sty = "" Then
sty = ele.Text
Else
sty = sty&", "&ele.Text
End If
Next
For Each ele In xml.getElementsByTagName("image")
img = ele.getAttribute("uri")
If Not (img = "") Then
Exit For
End If
Next
If img = "" Then
img = "http://trixmoto.net/files/none.jpg"
End If
End Select
For Each ele in xml.getElementsByTagName("track")
cur = cur+1
Next
If Not (gen = "") Then
inf = "Genre: "&gen&"<br>"
End If
If Not (sty = "") Then
inf = "Style: "&sty&"<br>"
End If
If Not (rel = "") Then
inf = "Released: "&rel&"<br>"
End If
inf = inf&"Tracks: "&Int(cur)
'finished
Call que.Remove("~"&nxt)
que.Item("#"&arr(2)) = Replace(que.Item("#"&arr(2)),"**"&nxt&"**",inf,1,1)
If Not (img = "") Then
que.Item("#"&arr(2)) = Replace(que.Item("#"&arr(2)),"*@"&nxt&"@*",img,1,1)
End If
If que.Item("nxt") = que.Item("tot") Then
que.Item("sts") = "DONE"
Else
que.Item("sts") = "READY"
End If
End Sub
Sub ClearUp(mes,typ)
Dim tmr : Set tmr = SDB.Objects("DiscographyReportTimer1")
If Not (tmr Is Nothing) Then
Call Script.UnregisterEvents(tmr)
Set SDB.Objects("DiscographyReportTimer1") = Nothing
End If
Set tmr = SDB.Objects("DiscographyReportTimer2")
If Not (tmr Is Nothing) Then
Call Script.UnregisterEvents(tmr)
Set SDB.Objects("DiscographyReportTimer2") = Nothing
End If
Set SDB.Objects("DiscographyReportQueue") = Nothing
Set SDB.Objects("DiscographyReportProgress") = Nothing
Set SDB.Objects("DiscographyReportList") = Nothing
Set SDB.Objects("DiscographyReportItem") = Nothing
Set SDB.Objects("DiscographyReportData") = Nothing
Set SDB.Objects("DiscographyReportXML") = Nothing
If Not (mes = "") Then
Call SDB.MessageBox("DiscographyReport: "&mes,typ,Array(mbOk))
End If
End Sub
Function fixurl(sRawURL)
Const sValidChars = "1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\/:"
Dim url : url = Replace(sRawURL,"+","%2B")
If UCase(Right(url,6)) = " (THE)" Then
url = "The "&Left(url,Len(url)-6)
End If
If UCase(Right(url,5)) = ", THE" Then
url = "The "&Left(url,Len(url)-5)
End If
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
fixurl = fixurl&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
Sub ShowReport()
'get queue
Dim que : Set que = SDB.Objects("DiscographyReportQueue")
If que Is Nothing Then
Call ClearUp("Sorry, the queue has been lost.",mtError)
Exit Sub
End If
'get list
Dim list : Set list = SDB.Objects("DiscographyReportData")
Dim a : a = list.Keys
Dim i : i = 0
'build report
Dim rep : Set rep = SDB.Tools.FileSystem.CreateTextFile(Script.ScriptPath&".htm",True)
rep.WriteLine "<html><head><title>"&AppTitle&"</title><style type=text/css>"
rep.WriteLine "body{font-family:'Verdana',sans-serif; background-color:#FFFFFF; font-size:9pt; color:#000000;}"
rep.WriteLine "H1{font-family:'Verdana',sans-serif; font-size:11pt; font-weight:bold; color:#000000; text-align:left}"
rep.WriteLine "TD{font-family:'Verdana',sans-serif; font-size:8pt; color:#000000;}"
rep.WriteLine "</style></head><body><h1>"&Left(AppTitle,InStrRev(AppTitle," ")-1)&"</h1>"
For i = 0 To list.Count-1
Dim itmID : itmID = 0
Dim nam : nam = a(i)
Dim sql : sql = "SELECT Id FROM Artists WHERE Artist='"&fixsqlart(nam)&"'"
If Debug Then
Call out("#"&sql)
End If
Dim iter : Set iter = SDB.Database.OpenSQL(sql)
If Not (iter.EOF) Then
itmID = iter.ValueByIndex(0)
End If
Set iter = Nothing
rep.WriteLine "<u>"&MapXML(nam)&"</u>"
rep.WriteLine " "&que.Item("#"&itmID)&"<br>"
Next
rep.WriteLine "</body></html>"
rep.Close
'show report
Call ClearUp("",mtInformation)
If SDB.MessageBox("DiscographyReport: Report complete, display now?",mtConfirmation,Array(mbYes,mbNo)) = mrYes Then
Dim wsh : Set wsh = CreateObject("WScript.Shell")
Call wsh.Run(Chr(34)&Script.ScriptPath&".htm"&Chr(34),1,0)
End If
End Sub
Function MapXML(original)
Dim hold : hold = original
hold = Replace(hold,"&","&")
hold = Replace(hold," "," ")
hold = Replace(hold,"<","<")
hold = Replace(hold,">",">")
Dim i : i = 1
While i<=Len(hold)
If (AscW(Mid(hold,i,1))>127) Then
hold = Mid(hold,1,i-1)+"&#"+CStr(AscW(Mid(hold,i,1)))+";"+Mid(hold,i+1)
End If
i = i + 1
WEnd
MapXML = hold
End Function
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("DiscographyReport","Filename") = "DiscographyReport.vbs"
inif.StringValue("DiscographyReport","Procname") = "DiscographyReport"
inif.StringValue("DiscographyReport","Order") = "50"
inif.StringValue("DiscographyReport","DisplayName") = "Discography Report"
inif.StringValue("DiscographyReport","Description") = "Lists missing albums of selected artists"
inif.StringValue("DiscographyReport","Language") = "VBScript"
inif.StringValue("DiscographyReport","ScriptType") = "1"
SDB.RefreshScriptItems
End If
End Sub
Sub SortData(data)
Dim i : i = 0
Dim a : a = data.Keys
Call SortArray(a)
Call data.RemoveAll
For i = 0 To UBound(a)
data.Item(a(i)) = ""
Next
End Sub
Sub SortArray(arr)
Call QuickSort(arr,LBound(arr),UBound(arr))
End Sub
Sub QuickSort(vec,loBound,hiBound)
Dim pivot,loSwap,hiSwap,temp
If hiBound - loBound = 1 Then
If Vec(loBound) > Vec(hiBound) Then
temp = Vec(loBound)
Vec(loBound) = Vec(hiBound)
Vec(hiBound) = temp
End If
End If
pivot = Vec(Int((loBound + hiBound) / 2))
Vec(Int((loBound + hiBound) / 2)) = Vec(loBound)
Vec(loBound) = pivot
loSwap = loBound + 1
hiSwap = hiBound
Do
While loSwap < hiSwap And Vec(loSwap) <= pivot
loSwap = loSwap + 1
WEnd
While Vec(hiSwap) > pivot
hiSwap = hiSwap - 1
WEnd
If loSwap < hiSwap then
temp = Vec(loSwap)
Vec(loSwap) = Vec(hiSwap)
Vec(hiSwap) = temp
End If
Loop While loSwap < hiSwap
Vec(loBound) = Vec(hiSwap)
Vec(hiSwap) = pivot
If loBound < (hiSwap - 1) Then
Call QuickSort(vec,loBound,hiSwap-1)
End If
If hiSwap + 1 < hibound Then
Call QuickSort(vec,hiSwap+1,hiBound)
End If
End Sub
Function fixsqlalb(name)
fixsqlalb = Replace(name,"'","''")
fixsqlalb = Replace(fixsqlalb,"&","&")
If Right(fixsqlalb,1) = "!" Then
fixsqlalb = Left(fixsqlalb,Len(fixsqlalb)-1)&"' OR Albums.Album = '"&fixsqlalb
Else
If Right(fixsqlalb,1) = "?" Then
fixsqlalb = Left(fixsqlalb,Len(fixsqlalb)-1)&"' OR Albums.Album = '"&fixsqlalb
Else
fixsqlalb = fixsqlalb&"' OR Albums.Album LIKE '"&fixsqlalb&"_"
End If
End If
If InStr(fixsqlalb," & ") > 0 Then
fixsqlalb = Replace(fixsqlalb," & "," And ")&"' OR Albums.Album = '"&Replace(fixsqlalb," & "," + ")&"' OR Albums.Album = '"&fixsqlalb
Else
If InStr(fixsqlalb," + ") > 0 Then
fixsqlalb = Replace(fixsqlalb," + "," And ")&"' OR Albums.Album = '"&Replace(fixsqlalb," + "," & ")&"' OR Albums.Album = '"&fixsqlalb
Else
If InStr(fixsqlalb," And ") > 0 Then
fixsqlalb = Replace(fixsqlalb," And "," & ")&"' OR Albums.Album = '"&Replace(fixsqlalb," And "," + ")&"' OR Albums.Album = '"&fixsqlalb
End If
End If
End If
End Function
Function fixsqlart(name)
fixsqlart = Replace(name,"'","''")
fixsqlart = Replace(fixsqlart,"&","&")
If SDB.IniFile.BoolValue("Options","IgnoreTHEs") Then
Dim str : str = SDB.IniFile.StringValue("Options","IgnoreTHEStrings")
If Not (str = "") Then
Dim thes : thes = Split(str,",")
Dim i : i = 0
For i = 0 To UBound(thes)
Dim s : s = Trim(thes(i))&" "
If UCase(Left(name,Len(s))) = UCase(s) Then
fixsqlart = Mid(fixsqlart,Len(s)+1)&"' OR Artist='"&fixsqlart
Exit For
End If
Next
End If
End If
End Function
Sub clear()
Dim wsh : Set wsh = CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim loc : loc = wsh.ExpandEnvironmentStrings("%TEMP%")
If Right(loc,1) = "\" Then
loc = loc&"DiscographyReport.log"
Else
loc = loc&"\DiscographyReport.log"
End If
Dim logf : Set logf = fso.CreateTextFile(loc,True)
logf.Close
End Sub
Sub out(txt)
Dim wsh : Set wsh = CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim loc : loc = wsh.ExpandEnvironmentStrings("%TEMP%")
If Right(loc,1) = "\" Then
loc = loc&"DiscographyReport.log"
Else
loc = loc&"\DiscographyReport.log"
End If
Dim logf : Set logf = fso.OpenTextFile(loc,8,True)
logf.WriteLine(Time&" "&SDB.ToAscii(txt))
logf.Close
End Sub
Function LoadLastFmXML(str)
Set LoadLastFmXML = CreateObject("Microsoft.XMLDOM")
Call LoadLastFmXML.LoadXML(str)
If LoadLastFmXML.parseError.errorCode <> 0 Then
Call out("@ErrorCode="&LoadLastFmXML.parseError.errorCode)
Call out("@ErrorMess="&LoadLastFmXML.parseError.reason)
Call out("@ErrorLine="&LoadLastFmXML.parseError.line)
Call out("@ErrorChar="&LoadLastFmXML.parseError.linepos)
Call out("@ErrorText="&LoadLastFmXML.parseError.srcText)
Set LoadLastFmXML = Nothing
Else
If InStr(str,"<lfm status=""ok"">") = 0 Then
Dim lfm : Set lfm = Nothing
For Each lfm In LoadLastFmXML.getElementsByTagName("lfm")
Call out("@ErrorStat="&lfm.attributes.getNamedItem("status").nodeValue)
Next
For Each lfm In LoadLastFmXML.getElementsByTagName("error")
Call out("@ErrorCode="&lfm.attributes.getNamedItem("code").nodeValue)
Call out("@ErrorMess="&lfm.Text)
Next
Set LoadLastFmXML = Nothing
End If
End If
End Function
Function LoadDiscogsXML(str)
Set LoadDiscogsXML = CreateObject("Microsoft.XMLDOM")
Call LoadDiscogsXML.LoadXML(str)
If LoadDiscogsXML.parseError.errorCode <> 0 Then
Call out("@ErrorCode="&LoadDiscogsXML.parseError.errorCode)
Call out("@ErrorMess="&LoadDiscogsXML.parseError.reason)
Call out("@ErrorLine="&LoadDiscogsXML.parseError.line)
Call out("@ErrorChar="&LoadDiscogsXML.parseError.linepos)
Call out("@ErrorText="&LoadDiscogsXML.parseError.srcText)
Set LoadDiscogsXML = Nothing
Else
If InStr(str,"<resp stat=""ok"" version=""1.0"" requests") = 0 Then
Set LoadDiscogsXML = Nothing
End If
End If
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
End Function