Code: Select all
'
' MediaMonkey Script
'
' NAME: iPlaylistImporter 1.6
'
' AUTHOR: trixmoto (http://trixmoto.net)
' DATE : 25/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
'
' [iPlaylistImporter]
' FileName=iPlaylistImporter.vbs
' ProcName=iPlaylistImporter
' Order=30
' DisplayName=iPlaylist Importer
' Description=Import XML playlists from iTunes
' Language=VBScript
' ScriptType=0
'
' FIXES: Fixed trim function doesn't work with tabs
'
Option Explicit
Dim Debug : Debug = False
Sub iPlaylistImporter
'get filename
Dim dlg : Set dlg = SDB.CommonDialog
dlg.Filter = "Playlist (XML)|*.xml"
dlg.Flags = cdlOFNOverwritePrompt + cdlOFNHideReadOnly + cdlOFNNoChangeDir
dlg.InitDir = SDB.MyMusicPath
dlg.ShowOpen
If Not dlg.Ok Then
Exit Sub
End If
Dim xml : xml = dlg.FileName
'create progress bar
Dim prog : Set prog = SDB.Progress
prog.Text = "iPlaylistImporter: Initialising..."
prog.Value = 0
prog.MaxValue = 1
'create parent playlist
Dim ply : Set ply = Nothing
Dim par : Set par = SDB.PlaylistByTitle("iPlaylists")
If par.Title = "" Then
Set par = SDB.PlaylistByTitle("").CreateChildPlaylist("iPlaylists")
End If
If par Is Nothing Then
Call SDB.MessageBox("iPlaylistImporter: Could not find or create 'iPlaylists' parent playlist.",mtError,Array(mbOk))
Exit Sub
End If
'create logfile
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
If Debug Then
Dim wsh : Set wsh = CreateObject("WScript.Shell")
Dim loc : loc = wsh.ExpandEnvironmentStrings("%TEMP%")&"\iPlaylistImporter.log"
Dim log : Set log = fso.CreateTextFile(loc,True)
If log Is Nothing Then
Debug = False
Else
Call log.WriteLine("Import file: "&xml)
End If
End If
'initialise
Dim mode : mode = 0
Dim trid : trid = 0
Dim fndt : fndt = 0
Dim cret : cret = 0
Dim fndp : fndp = 0
Dim crep : crep = 0
Dim dic : Set dic = CreateObject("Scripting.Dictionary")
Dim dat : Set dat = CreateObject("Scripting.Dictionary")
Dim dtn : Set dtn = CreateObject("Scripting.Dictionary")
Dim txt : Set txt = fso.OpenTextFile(xml,1,False)
Dim prg : prg = ""
Dim tot : tot = 0
Dim gtot : gtot = 0
'read file
Do While Not txt.AtEndOfStream
Dim str : str = txt.ReadLine
If InStr(str,"<") > 0 Then
str = Mid(str,InStr(str,"<"))
End If
Dim key : key = gettag(str,"key")
Select Case mode
Case 0 'reading header
If key = "Tracks" Then
mode = 1
trid = 0
End If
Case 1 'reading tracks
If key = "Playlists" Then
mode = 3
trid = 0
Else
If key = "Track ID" Then
mode = 2
trid = Int(gettag(str,"integer"))
Set dat = CreateObject("Scripting.Dictionary")
prog.Text = "iPlaylistImporter: Reading XML file (Track ID = "&trid&")..."
SDB.ProcessMessages
If Debug Then Call log.Write("Reading track: "&CStr(trid))
End If
End If
Case 2 'reading track data
If key = "" Then
Set dic.Item(CStr(trid)) = dat
mode = 1
trid = 0
If Debug Then Call log.WriteLine(": "&dat.Item("Name"))
Else
dat.Item(CStr(key)) = gettag2(str)
End If
Case 3 'reading playlists
If key = "Name" Then
mode = 4
tot = 0
Dim nam : nam = Replace(gettag(str,"string"),"&","&")
Set ply = SDB.PlaylistByTitle(nam)
If Not (ply.Title = "") Then
trid = SDB.MessageBox("iPlaylistImporter: Do you wish to overwrite playlist '"&nam&"'?",mtConfirmation,Array(mbYes,mbNo))
If trid = mrNo Then
mode = 3
End If
End If
If mode = 4 Then
If ply.Title = "" Then
crep = crep+1
Set ply = par.CreateChildPlaylist(nam)
If Debug Then Call log.WriteLine("**Creating playlist: "&ply.Title)
prg = "iPlaylistImporter: Creating playlist '"
Else
fndp = fndp+1
Call ply.Clear()
If Debug Then Call log.WriteLine("**Updating playlist: "&ply.Title)
prg = "iPlaylistImporter: Updating playlist '"
End If
prog.Text = prg&ply.Title&"'..."
SDB.ProcessMessages
Set dtn.Item((crep+fndp)&"p") = ply
Else
Set ply = Nothing
End If
End If
Case 4 'reading playlist data
If key = "Track ID" Then
trid = gettag(str,"integer")
If dic.Exists(CStr(trid)) Then
Set dat = dic.Item(CStr(trid))
tot = tot+1
gtot = gtot+1
Set dtn.Item((crep+fndp)&"d"&tot) = dat
End If
Else
If str = "</array>" Then
mode = 3
End If
End If
Case Else
Call SDB.MessageBox("iPlaylistImport: Unknown mode '"&mode&"'.",mtError,Array(mbOk))
Exit Sub
End Select
If prog.Terminate Then
Exit Do
End If
Loop
txt.Close
'create playlists
prog.MaxValue = gtot
Dim max : max = crep+fndp
For trid = 1 To max
If dtn.Exists(trid&"p") Then
Set ply = dtn.Item(trid&"p")
tot = 1
While (dtn.Exists(trid&"d"&tot))
Set dat = dtn.Item(trid&"d"&tot)
Dim fil : fil = fixhex(dat.Item("Location"))
If Left(fil,7) = "file://" Then
fil = Mid(fil,8)
End If
If InStr(fil,":") > 0 Then
fil = Mid(fil,InStr(fil,":")-1)
End If
fil = Replace(fil,"/","\")
Dim upd : upd = False
Dim itm : Set itm = Nothing
Dim pat : pat = Replace(Mid(fil,2),"'","''")
Dim sit : Set sit = SDB.Database.QuerySongs("AND (Songs.SongPath = '"&pat&"')")
If sit.EOF Then
cret = cret+1
Set itm = SDB.NewSongData
upd = True
If Debug Then Call log.Write("****Creating track: ")
Else
fndt = fndt+1
Set itm = sit.Item
upd = False
If Debug Then Call log.Write("****Updating track: ")
End If
Set sit = Nothing
If upd Then
itm.Path = fil
itm.AlbumName = dat.Item("Album")
itm.ArtistName = dat.Item("Artist")
itm.Year = dat.Item("Year")
itm.Genre = dat.Item("Genre")
itm.Title = dat.Item("Name")
itm.TrackOrder = dat.Item("Track Number")
itm.UpdateDB
itm.UpdateArtist
itm.UpdateAlbum
Dim list : Set list = SDB.NewSongList
Call list.Add(itm)
Call list.UpdateAll()
End If
If Debug Then Call log.WriteLine(itm.Title&" ("&itm.ID&")")
prog.Text = "iPlaylistImporter: Adding track '"&itm.Title&"'..."
prog.Increase
SDB.ProcessMessages
Call ply.AddTrack(itm)
tot = tot+1
WEnd
End If
Next
'finish off
prog.Text = "iPlaylistImporter: Finalising..."
prog.Value = prog.MaxValue
SDB.ProcessMessages
If Debug Then
Call log.WriteBlankLines(1)
Call log.WriteLine((fndt+cret)&" tracks (found "&fndt&", created "&cret&")")
Call log.WriteLine((fndp+crep)&" playlists (found "&fndp&", created "&crep&")")
If prog.Terminate Then
Call log.WriteLine("**Cancelled by user")
End If
log.Close
End If
If Not prog.Terminate Then
Call SDB.MessageBox("iPlaylistImporter: "&(fndt+cret)&" tracks (found "&fndt&", created "&cret&") added to "&max&" playlists (found "&fndp&", created "&crep&").",mtInformation,Array(mbOk))
End If
End Sub
Function fixhex(str)
fixhex = str
Dim s1,s2,s3,d1,d2,b1,b2,b3
Dim i : i = InStr(fixhex,"%")
While (i > 0)
s1 = Mid(fixhex,i+1,2)
If IsHex(s1) Then
d1 = HexToDec(s1)
s1 = Left(fixhex,i-1)
s2 = Mid(fixhex,i+4,2)
If (Mid(fixhex,i+3,1) = "%") And (IsHex(s2)) Then
d2 = HexToDec(s2)
b1 = DecToBin(d1)
b2 = DecToBin(d2)
If (Left(b1,3) = "110") And (Left(b2,2) = "10") Then
b3 = Mid(b1,4)&Mid(b2,3)
s2 = ChrW(BinToDec(b3))
s3 = Mid(fixhex,i+6)
Else
s2 = Chr(d1)
s3 = Mid(fixhex,i+3)
End If
Else
s2 = Chr(d1)
s3 = Mid(fixhex,i+3)
End If
fixhex = s1&s2&s3
End If
i = InStr(i+1,fixhex,"%")
WEnd
End Function
Function IsHex(h)
IsHex = False
Dim i : i = 0
For i = 1 To Len(h)
If Instr("0123456789ABCDEF",UCase(Mid(h,i,1))) = 0 Then
Exit Function
End If
Next
IsHex = True
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)
DecToBin = ""
Dim d : d = intDec
Dim e : e = 128
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 BinToDec(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
d = 0
Exit For
End Select
Next
BinToDec = d
End Function
Function gettag(str,tag)
gettag = ""
Dim p1 : p1 = InStr(str,"<"&tag&">")
If p1 > 0 Then
Dim p2 : p2 = InStr(str,"</"&tag&">")
If p2 > 0 And p2 > p1 Then
p1 = p1+Len(tag)+2
gettag = Mid(str,p1,p2-p1)
End If
End If
End Function
Function gettag2(str)
gettag2 = gettag(str,"string")
If gettag2 = "" Then
gettag2 = gettag(str,"integer")
If gettag2 = "" Then
gettag2 = gettag(str,"date")
End If
Else
gettag2 = Replace(gettag2,"&","&")
End If
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("iPlaylistImporter","Filename") = "iPlaylistImporter.vbs"
inif.StringValue("iPlaylistImporter","Procname") = "iPlaylistImporter"
inif.StringValue("iPlaylistImporter","Order") = "30"
inif.StringValue("iPlaylistImporter","DisplayName") = "iPlaylist Importer"
inif.StringValue("iPlaylistImporter","Description") = "Import XML playlists from iTunes"
inif.StringValue("iPlaylistImporter","Language") = "VBScript"
inif.StringValue("iPlaylistImporter","ScriptType") = "0"
SDB.RefreshScriptItems
End If
End Sub