Private Sub PlaylistWPL_test()
Dim Path As String, PlaylistPath As String
Path = "D:\Sounds\"
PlaylistPath = VBA.Environ("USERPROFILE") & "\Music\Playlist\Sounds\"
Call PlaylistWPL(Path, Path, , Playlists, 1, "*.mp3", PlaylistPath:=PlaylistPath)
End Sub
Private Sub PlaylistWPL(ByVal Paths, _
Optional ByVal ParentFolder As String, _
Optional ByRef FSO As Object, _
Optional ByRef Playlists As Variant, _
Optional ByVal IncludeSubfolders As Boolean = False, _
Optional ByVal Types = "*.*", _
Optional ByVal NameTypes = "", _
Optional ByVal PlaylistPath As String = "")
'----------------------------------
Call CreateFolder(PlaylistPath)
Dim title$
Dim author$
Dim totalDuration&
Dim Subtitle$
Dim ContentPartnerName$
Dim ContentPartnerNameType$
Dim ContentPartnerListID$
Dim IsFavorite$
Dim ItemCount&
Dim Generator$
'----------------------------------
If VBA.TypeName(Paths) = "String" Then Paths = Array(Paths)
Dim I&, J&, k&, T$, T2$
Dim aTypes(), Arr(), dArr()
Dim SF, Folder
Dim Item As Object 'Scripting.File
Dim oFolder As Object 'Scripting.Folder
I = -1
If VBA.TypeName(NameTypes) = "String" Then
If NameTypes <> vbNullString Then ReDim aTypes(0): aTypes(0) = VBA.LCase(NameTypes)
Else
ReDim aTypes(UBound(NameTypes))
For I = LBound(Playlists) To UBound(Playlists): Arr(I) = VBA.LCase(NameTypes(I)): Next I
End If
If VBA.TypeName(Types) = "String" Then
ReDim aTypes(I + 1)
aTypes(I + 1) = "*" & VBA.LCase(Types)
Else
ReDim aTypes(UBound(Types) + VBA.IIf(I = -1, 0, I))
For k = LBound(Types) To UBound(Types): aTypes(k + VBA.IIf(I = -1, 0, I)) = "*" & VBA.LCase(Types(k)): Next k
End If
If FSO Is Nothing Then Set FSO = VBA.CreateObject("Scripting.FileSystemObject")
I = 0
If VBA.IsArray(Playlists) Then
ReDim Arr(1 To UBound(Playlists) - LBound(Playlists) + 1)
For I = LBound(Playlists) To UBound(Playlists) - LBound(Playlists) + 1: Arr(I) = Playlists(I): Next I
I = I - 1
End If
k = 0
'-----------------------------
Dim Tmp$, tTime$, PlaylistFile$, medias$
Dim ItemName, Attr$, NodeValue$, src$, albumTitle$, albumArtist$, trackTitle$, trackArtist$
Dim duration&, S$, Elem, NewElem
Dim Shl As Object, ShellFolder As Object
Set Shl = VBA.CreateObject("Shell.Application")
'-----------------------------
For Each Folder In Paths
If FSO.FolderExists(Folder) Then
Set oFolder = FSO.GetFolder(Folder)
title = VBA.Replace(VBA.Replace(Folder, ParentFolder, ""), "\", " ~ ")
If Not title Like "*" & oFolder.Name Then
title = title & oFolder.Name
End If
title = VBA.Right(title, 250)
I = I + 1: ReDim Preserve Arr(1 To I): Arr(I) = title
ItemCount = 0: totalDuration = 0: Tmp = VBA.vbNullString: medias = VBA.vbNullString
For Each Item In oFolder.Files
T = vbNullString: T = VBA.LCase(Item.Name)
T2 = vbNullString: T2 = VBA.LCase(Item.Type)
For Each SF In aTypes
If VBA.Left(T, 1) <> "~" And (T Like SF Or T2 = SF) Then
Set ShellFolder = Shl.Namespace(CVar(VBA.Replace(Item.Path, Item.Name, "")))
Set ItemName = ShellFolder.ParseName(Item.Name)
tTime = ShellFolder.GetDetailsOf(ItemName, 27)
If tTime <> "" Then
src = Item.Path
albumTitle = ShellFolder.GetDetailsOf(ItemName, 14)
albumArtist = ShellFolder.GetDetailsOf(ItemName, 204)
trackTitle = ShellFolder.GetDetailsOf(ItemName, 21)
trackArtist = ShellFolder.GetDetailsOf(ItemName, 13)
duration = VBA.CDec(VBA.Left(tTime, 2)) * 3600 + VBA.CDec(VBA.MID(tTime, 4, 2)) * 60 + VBA.CDec(VBA.Right(tTime, 2))
totalDuration = VBA.CDec(duration) + totalDuration
ItemCount = ItemCount + 1
GoSub AddSong
End If
Exit For
End If
DoEvents
Next SF
Next Item
'-----------------------------------
If ItemCount > 0 Then GoSub Save
'-----------------------------------
If IncludeSubfolders Then
For Each SF In oFolder.SubFolders
k = k + 1: ReDim Preserve dArr(1 To k): dArr(k) = SF.Path
Next SF
End If
'-----------------------------
End If
Next Folder
'-----------------------------
If I > 0 Then Playlists = Arr
If IncludeSubfolders And k > 0 Then
PlaylistWPL dArr, ParentFolder, FSO, Playlists, True, Types, NameTypes, PlaylistPath
End If
Exit Sub:
AddSong:
medias = medias & VBA.IIf(medias = "", "", VBA.Chr(10)) & "<media src=""" & src & """" & _
" albumTitle=""" & albumTitle & """" & _
" albumArtist=""" & albumArtist & """" & _
" trackTitle=""" & trackTitle & """" & _
" trackArtist=""" & trackArtist & """" & _
" duration=""" & duration & """ />"
Return
'---------------------------------------
Save:
S = "<?wpl version=""1.0"" encoding=""utf-8"" ?>"
S = S & "<smil>"
S = S & " <head>"
S = S & " <author content=""" & author & """ />"
S = S & " <guid>{CFF37028-F641-4708-ABB4-D63E359ABC70}</guid>"
S = S & " <meta name=""totalDuration"" content=""" & totalDuration & """ />"
S = S & " <meta name=""Subtitle"" content=""" & Subtitle & """ />"
S = S & " <meta name=""ContentPartnerName"" content=""" & ContentPartnerName & """ />"
S = S & " <meta name=""ContentPartnerNameType"" content=""" & ContentPartnerNameType & """ />"
S = S & " <meta name=""ContentPartnerListID"" content=""" & ContentPartnerListID & """ />"
S = S & " <meta name=""IsFavorite"" content=""" & IsFavorite & """ />"
S = S & " <meta name=""ItemCount"" content=""" & ItemCount & """ />"
S = S & " <meta name=""Generator"" content=""Entertainment Platform -- 10.18111.1731.0"" />"
S = S & " <title>" & title & "</title>"
S = S & " </head>"
S = S & " <body><seq>" & medias
S = S & VBA.Chr(10) & " </seq> "
S = S & VBA.Chr(10) & " </body> "
S = S & VBA.Chr(10) & "</smil> "
Dim objDom As Object
Set objDom = VBA.CreateObject("MSXML2.DOMDocument")
objDom.LoadXML (S)
objDom.Save (PlaylistPath & title & ".wpl")
Set objDom = Nothing
Return
End Sub
Function CreateFolder(ByVal FolderPath$) As Boolean
Dim FolderArray, Tmp$, Item, tFolder$
tFolder = FolderPath
If VBA.Right(tFolder, 1) = "\" Then tFolder = VBA.Left(tFolder, VBA.Len(tFolder) - 1)
If tFolder Like "\\*\*" Then tFolder = VBA.Strings.Replace(tFolder, "\", "@", 1, 3)
FolderArray = VBA.Split(tFolder, "\")
FolderArray(0) = VBA.Strings.Replace(FolderArray(0), "@", "\", 1, 3)
On Error GoTo Ends
With VBA.CreateObject("Scripting.FileSystemObject")
For Each Item In FolderArray
Tmp = Tmp & Item & "\"
If Not .FolderExists(Tmp) Then .CreateFolder (Tmp)
Next
End With
CreateFolder = True
Ends:
End Function
