As always, installers are available from my website.
Code: Select all
'
' MediaMonkey Script
'
' NAME: FindSyncDups 1.3
'
' AUTHOR: trixmoto (http://trixmoto.net)
' DATE : 27/05/2008
'
' INSTALL: Copy to Scripts directory and add the following to Scripts.ini
' Don't forget to remove comments (') and set the order appropriately
'
' [FindSyncDups]
' FileName=FindSyncDups.vbs
' ProcName=FindSyncDups
' Order=41
' DisplayName=Find Sync Dups
' Description=Find duplicate tracks in sync list
' Language=VBScript
' ScriptType=1
'
' FIXES: Fixed ordering of non-numeric disc and track numbers
' Added disc number to report display
' Fixed albums with multiple track versions should not be reported
' Added duplicates now colour coded
'
Option Explicit
Dim AppTitle : AppTitle = "Find Sync Dups 1.3"
Sub FindSyncDups()
'select device
Dim arr,str,lst,i,j,k,sts
Dim devc : devc = 0
Dim devi : devi = ""
Dim devn : devn = ""
Dim devd : Set devd = CreateObject("Scripting.Dictionary")
Dim dit : Set dit = SDB.Database.OpenSQL("SELECT DeviceCaption,ID FROM Devices WHERE DeviceID <> ''")
While Not dit.EOF
devc = devc+1
devn = dit.StringByIndex(0)
devi = dit.StringByIndex(1)
devd.Item(devi) = devn
dit.Next
WEnd
If devc < 1 Then
Call SDB.MessageBox("FindSyncDups: You have no synchronised devices.",mtError,Array(mbOk))
Exit Sub
End If
If devc > 1 Then
devn = SkinnedListBox("Please select device:","FindSyncDups",devd.Items)
If devn = "" Then
Exit Sub
End If
arr = devd.Keys
For i = 0 To UBound(arr)
If devd.Item(arr(i)) = devn Then
devi = arr(i)
Exit For
End If
Next
End If
'create progress bar
Dim prog : Set prog = SDB.Progress
prog.Value = 0
prog.MaxValue = 1
prog.Text = "FindSyncDups: Initialising..."
SDB.ProcessMessages
'list tracks
Dim trac : trac = 0
Dim trad : Set trad = CreateObject("Scripting.Dictionary")
Set dit = SDB.Database.OpenSQL("SELECT IDTrack,ID FROM DeviceTracks WHERE IDDevice = "&devi)
While Not dit.EOF
trac = trac+1
trad.Item(dit.StringByIndex(0)) = dit.StringByIndex(1)
dit.Next
WEnd
If trac < 1 Then
Call SDB.MessageBox("FindSyncDups: You have no synchronised tracks.",mtError,Array(mbOk))
Exit Sub
End If
'process tracks
prog.MaxValue = trac
Dim dupc : dupc = 0
arr = trad.Keys
Set trad = CreateObject("Scripting.Dictionary")
Set devd = CreateObject("Scripting.Dictionary")
Dim sit : Set sit = Nothing
For i = 0 To UBound(arr)
prog.Value = i
prog.Text = "FindSyncDups: Checking track "&(i+1)&" of "&(trac)&" (found: "&dupc&")..."
SDB.ProcessMessages
Set sit = SDB.Database.QuerySongs("AND Songs.ID = "&arr(i))
If Not (sit.EOF) Then
sts = UCase(sit.Item.ArtistName)
str = sts&" *** "&UCase(sit.Item.Title)
If devd.Exists(sts) Then
devd.Item(sts) = devd.Item(sts)&","&sit.Item.Album.ID
Else
devd.Item(sts) = sit.Item.Album.ID
End If
If trad.Exists(str) Then
dupc = dupc+1
Set lst = trad.Item(str)
Else
Set lst = SDB.NewSonglist
End If
Call lst.Add(sit.Item)
Set trad.Item(str) = lst
End If
If prog.Terminate Then
Exit Sub
End If
Next
If dupc < 1 Then
Call SDB.MessageBox("FindSyncDups: You have no duplicate synchronised tracks.",mtError,Array(mbOk))
Exit Sub
End If
'remove non-duplicates
prog.Text = "FindSyncDups: Calculating duplicates..."
SDB.ProcessMessages
Dim albd : Set albd = CreateObject("Scripting.Dictionary")
arr = trad.Keys
dupc = 0
For i = 0 To UBound(arr)
Set lst = trad.Item(arr(i))
If lst.Count > 1 Then
Set albd = CreateObject("Scripting.Dictionary")
For j = 0 To lst.Count-1
albd.Item(lst.Item(j).AlbumName) = ""
Next
If albd.Count > 1 Then
dupc = dupc+1
prog.MaxValue = prog.MaxValue+1
Else
Call trad.Remove(arr(i))
End If
Else
Call trad.Remove(arr(i))
End If
If prog.Terminate Then
Exit Sub
End If
Next
'create report
prog.Text = "FindSyncDups: Initialising report..."
SDB.ProcessMessages
Dim wsh : Set wsh = CreateObject("WScript.Shell")
Dim loc : loc = wsh.ExpandEnvironmentStrings("%TEMP%")&"\FincSyncDups.htm"
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim out : Set out = fso.CreateTextFile(loc,True,True)
Call out.WriteLine("<html><head><title>"&AppTitle&"</title><style type=text/css>")
Call out.WriteLine("body{font-family:'Verdana',sans-serif; background-color:#FFFFFF; font-size:9pt; color:#000000;}")
Call out.WriteLine("H1{font-family:'Verdana',sans-serif; font-size:13pt; font-weight:bold; color:#AAAAAA; text-align:left}")
Call out.WriteLine("TH{font-family:'Verdana',sans-serif; font-size:10pt; font-weight:bold; color:#000000; border-color:#000000; border-style: solid; border-left-width:0px; border-right-width:0px; border-top-width:0px; border-bottom-width:3px;}")
Call out.WriteLine("TD{font-family:'Verdana',sans-serif; font-size:9pt; color:#000000; border-color:#000000; border-style: solid; border-left-width:0px; border-right-width:0px; border-top-width:0px; border-bottom-width:1px; vertical-align:top}")
Call out.WriteLine("</style></head><body>")
'process duplicates
Dim col : col = ""
Dim maxv : maxv = prog.MaxValue-1
Dim lstd : Set lstd = CreateObject("Scripting.Dictionary")
Dim artd : Set artd = CreateObject("Scripting.Dictionary")
Set albd = CreateObject("Scripting.Dictionary")
arr = trad.Keys
For i = 0 To UBound(arr)
prog.Value = trac+i
prog.Text = "FindSyncDups: Processing duplicate "&(i-maxv)&" of "&(dupc)&"..."
SDB.ProcessMessages
Set lst = trad.Item(arr(i))
Dim tmp : tmp = Split(arr(i)," *** ")
Dim art : art = tmp(0)
Dim ttl : ttl = tmp(1)
If Not (artd.Exists(art)) Then
str = devd.Item(art)
artd.Item(art) = str
tmp = StrToArray(str)
Dim alb : Set alb = Nothing
Call out.WriteLine("<h1>"&art&"</h1><table><tr>")
For j = 0 To UBound(tmp)
If albd.Exists(tmp(j)) Then
Set alb = albd.Item(tmp(j))
Else
str = "AND Songs.IDAlbum = "&tmp(j)
If SDB.VersionHi > 2 Then
str = str&" ORDER BY DiscNumber COLLATE NUMERICSTRING, TrackNumber COLLATE NUMERICSTRING"
Else
str = str&" ORDER BY Songs.SongOrder"
End If
Set sit = SDB.Database.QuerySongs(str)
Set alb = sit.Item.Album
Set lst = SDB.NewSongList
While Not sit.EOF
Call lst.Add(sit.Item)
sit.Next
WEnd
Set albd.Item(tmp(j)) = alb
Set lstd.Item(tmp(j)) = lst
End If
If Not(alb Is Nothing) And (alb.ID > 0) Then
Call out.WriteLine("<th>"&alb.Name&"</th>")
Else
Call out.WriteLine("<th> </th>")
End If
Next
Call out.WriteLine("</tr><tr>")
Dim cold : Set cold = CreateObject("Scripting.Dictionary") '!!!
For j = 0 To UBound(tmp)
str = "<td>"
Set alb = albd.Item(tmp(j))
Set lst = lstd.Item(tmp(j))
For k = 0 To lst.Count-1
Dim itm : Set itm = lst.Item(k)
Dim dupb : dupb = False
Dim key : key = UCase(itm.ArtistName&" *** "&itm.Title)
If trad.Exists(key) Then
If cold.Exists(key) Then
str = str&"<font color="""&cold.Item(key)&""">"
Else
col = GetNextColour(col)
cold.Item(key) = col
str = str&"<font color="""&col&""">"
End If
dupb = True
End If
If SDB.VersionHi > 2 Then
If itm.TrackOrderStr = "" Then
str = str&itm.Title
Else
If itm.DiscNumberStr = "" Then
str = str&itm.TrackOrderStr&". "&itm.Title
Else
str = str&itm.DiscNumberStr&"-"&itm.TrackOrderStr&". "&itm.Title
End If
End If
Else
If itm.TrackOrder > 0 Then
str = str&itm.TrackOrder&". "&itm.Title
Else
str = str&itm.Title
End If
End If
If Not (itm.ArtistName = alb.Artist.Name) Then
str = str&" ("&itm.ArtistName&")"
End If
If dupb Then
str = str&"</font>"
End If
If k < lst.Count-1 Then
str = str&"<br>"
End if
Next
Call out.WriteLine(str&"</td>")
Next
Call out.WriteLine("</tr></table>")
End If
If prog.Terminate Then
Exit For
End If
Next
'show report
Call out.WriteLine("</body></html>")
Call out.Close()
If Not (prog.Terminate) Then
prog.Value = prog.MaxValue
prog.Text = "FindSyncDups: Report complete."
If SDB.MessageBox("FindSyncDups: Report complete, display now?",mtConfirmation,Array(mbYes,mbNo)) = mrYes Then
Call wsh.Run(Chr(34)&loc&Chr(34),1,0)
End If
End If
End Sub
Function GetNextColour(col)
Select Case col
Case "red"
GetNextColour = "blue"
Case "blue"
GetNextColour = "green"
Case "green"
GetNextColour = "gold"
Case "gold"
GetNextColour = "skyblue"
Case "skyblue"
GetNextColour = "purple"
Case "purple"
GetNextColour = "yellowgreen"
Case "yellowgreen"
GetNextColour = "violet"
Case "violet"
GetNextColour = "teal"
Case "teal"
GetNextColour = "sienna"
Case "sienna"
GetNextColour = "darkkhaki"
Case "darkkhaki"
GetNextColour = "lightsalmon"
Case Else
GetNextColour = "red"
End Select
End Function
Function SkinnedListBox(Text, Caption, Options)
Dim Form, Label, Edt, btnOk, btnCancel, modalResult, i
' Create the window to be shown
Set Form = SDB.UI.NewForm
Form.Common.SetRect 100, 100, 360, 130
Form.BorderStyle = 2 ' Resizable
Form.FormPosition = 4 ' Screen Center
Form.Caption = Caption
' Create a button that closes the window
Set Label = SDB.UI.NewLabel(Form)
Label.Caption = Text
Label.Common.Left = 5
Label.Common.Top = 10
Set Edt = SDB.UI.NewDropDown(Form)
Edt.Common.Left = Label.Common.Left
Edt.Common.Top = Label.Common.Top + Label.Common.Height + 5
Edt.Common.Width = Form.Common.Width - 20
Edt.Common.ControlName = "Edit1"
Edt.Common.Anchors = 1+2+4 'Left+Top+Right
Edt.Style = 2
Edt.AddItem("Please select...")
For i = 0 To UBound(Options)
Edt.AddItem(Options(i))
Next
Edt.ItemIndex = 0
' Create a button that closes the window
Set BtnOk = SDB.UI.NewButton(Form)
BtnOk.Caption = "&OK"
BtnOk.Common.Top = Edt.Common.Top + Edt.Common.Height + 10
BtnOk.Common.Hint = "OK"
BtnOk.Common.Anchors = 4 ' Right
BtnOk.UseScript = Script.ScriptPath
BtnOk.Default = True
BtnOk.ModalResult = 1
Set BtnCancel = SDB.UI.NewButton(Form)
BtnCancel.Caption = "&Cancel"
BtnCancel.Common.Left = Form.Common.Width - BtnCancel.Common.Width - 15
BtnOK.Common.Left = BtnCancel.Common.Left - BtnOK.Common.Width - 10
BtnCancel.Common.Top = BtnOK.Common.Top
BtnCancel.Common.Hint = "Cancel"
BtnCancel.Common.Anchors = 4 ' Right
BtnCancel.UseScript = Script.ScriptPath
BtnCancel.Cancel = True
BtnCancel.ModalResult = 2
If (Form.showModal = 1) And (Edt.ItemIndex > 0) Then
SkinnedListBox = Options(Edt.ItemIndex-1)
Else
SkinnedListBox = ""
End If
End Function
Function StrToArray(str)
Dim i : i = 0
Dim dic : Set dic = CreateObject("Scripting.Dictionary")
Dim arr : arr = Split(str,",")
For i = 0 To UBound(arr)
dic.Item(arr(i)) = i
Next
StrToArray = dic.Keys
End Function
Function MapXML(srcstring)
MapXML = srcstring
MapXML = Replace(MapXML,"&","&")
MapXML = Replace(MapXML,"<","<")
MapXML = Replace(MapXML,">",">")
MapXML = Replace(MapXML,"""",""")
Dim i : i = 1
While i<=Len(MapXML)
If (AscW(Mid(MapXML,i,1))>127) Then
MapXML = Mid(MapXML,1,i-1)+"&#"+CStr(AscW(Mid(MapXML,i,1)))+";"+Mid(MapXML,i+1,Len(MapXML))
End If
i = i + 1
WEnd
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("FindSyncDups","Filename") = "FindSyncDups.vbs"
inif.StringValue("FindSyncDups","Procname") = "FindSyncDups"
inif.StringValue("FindSyncDups","Order") = "41"
inif.StringValue("FindSyncDups","DisplayName") = "Find Sync Dups"
inif.StringValue("FindSyncDups","Description") = "Find duplicate tracks in sync list"
inif.StringValue("FindSyncDups","Language") = "VBScript"
inif.StringValue("FindSyncDups","ScriptType") = "1"
SDB.RefreshScriptItems
End If
End Sub