http://dieseyer.de • all rights reserved • © 2011 v11.4

'v5.C===========================================================================================
'
' NAME: convert-b4s-to-m3u.vbs
'
' AUTOR: Michael Wende - wende@helimail.de
' dieseyer.de
' DATUM: 28.12.05
'
' KOMMENTAR: Wandelt in einem angegebenen Ordner alle .4bs Winampplaylistdatei(en)
' in m3u Playlist(en). Die Idee kam mir, als ich einige Winamp Playlisten
' für die Sylvesterparty auf CD brennen wollte. Mir fiel auf, dass ich
' noch einige .b4s Winamp3 Playlisten auf meinem Rechner habe. Mittlerweile
' habe ich Winamp 5 im Einsatz. Zu meinem Entsetzen kann Winamp 5 diese nicht
' abspielen oder konvertieren. Auch mein Brennprogramm Nero kann mit .b4s
' Dateien nichts anfangen. Bei meiner Suche im Internet kam ich auf ein
' Freewaretool "veeXChange" von www.krank.hu. Mein Virenscanner meinte aber,
' dass diese .zip Datei verseucht sei und löschte sie wieder.
' So kam ich auf die Idee, mir ein geeignetes Skript selbst zu schreiben...
'==================================================================================================

' Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl

Dim myxmlstr,myxmlstr2,myxmlstr3
Dim myfsObject,dateiname,m3uFile,textziel
Dim Ordner,Song,Laenge,arg,antwort
Dim strfiles(),vonAnfang,bisEnde,i,anzfiles

Set myfsObject=CreateObject("Scripting.FileSystemObject")
Set oFs=CreateObject("Scripting.FileSystemObject")
arg = BrowseForFile("Bitte Ordner mit .b4s Playlisten auswählen!","Ordnerwahl")
If arg = "" Then
WScript.Quit
End If

If Mid(arg,Len(arg),Len(arg))= "\" then ' Ist Backslash am Ende,dann OK
textziel = arg
Else
textziel = arg & "\" ' sonst Backslash anhängen
End If
Redim strfiles(0)

strfiles(0)=""
anzfiles=0
walkdirs(textziel)
If anzfiles > 0 Then
antwort= MsgBox("Fertig! m3u Playliste(n) wurden erstellt. Möchten Sie jetzt die .b4s Playlisten löschen?",VbYesNo,"Achtung!")
If antwort = VbYes Then
vonAnfang =LBound(strfiles) : bisEnde = UBound(strfiles)
For i=vonAnfang To bisEnde
' MsgBox strfiles(i) & " wird gelöscht!"
oFs.DeleteFile(strfiles(i))
Next
MsgBox "Alle .b4s Winamp3 Playlisten wurden gelöscht!"
End If
Else
MsgBox "Sorry, ich konnte leider keine .b4s Winamp3 Playlisten finden!"
End If

' Ende des Programmes

' ********* Funktionen und Unterprogramme (Subs) **********************************************************

'*********************************************************
Sub walkdirs(arg)
'*********************************************************
If oFs.FolderExists(arg) Then
Set thisDir = oFs.GetFolder(arg)
Set subDirs = thisDir.SubFolders
Set theseFiles = thisDir.Files

If subDirs.Count > 0 Then
For Each dirName in subDirs
walkdirs(dirName)
Next
End If

For Each fileName in theseFiles
If oFs.GetExtensionName(fileName) = "b4s" Then
If strfiles(0) = "" Then
strfiles(0) = fileName
Else
Redim Preserve strfiles(Ubound(strfiles,1) + 1)
strfiles(Ubound(strfiles,1)) = fileName
End If
End If
walkdirs(fileName)
Next

ElseIf oFs.FileExists(arg) Then

If oFs.GetExtensionName(arg) = "b4s" Then
convertFile(arg)
End If

End If
End Sub ' walkdirs(arg)


'*********************************************************
Sub convertFile(fname)
'*********************************************************
'Zur Veranschaulichung konvertiert wird von Beispiel1 nach Beispiel2
'Beispiel1 .b4s Winampplaylist
'<?xml version="1.0" encoding="us-ascii" standalone="yes"?>
'<WinampXML>
' <playlist num_entries="0" label="">
' <entry Playstring="H:\CREAM - Cream Live\01 - CREAM - N.S.U..mp3">
' <Name>CREAM - N.S.U.</Name>
' <Length>615000</Length></entry>
' <entry Playstring="H:\CREAM - Cream Live\02 - CREAM - Sleepy Time Time.mp3">
' <Name>CREAM - Sleepy Time Time</Name>
' <Length>412000</Length></entry>
'
'Beispiel2 .m3u Winampplaylist
'#EXTM3U
'#EXTINF:615,CREAM - N.S.U.
'01 - CREAM - N.S.U..mp3
'#EXTINF:412,CREAM - Sleepy Time Time
'02 - CREAM - Sleepy Time Time.mp3

Dim m3ufile,sMP3,oFS,oFile,oM3U
m3ufile = Left(fname, Len(fname) - 4) & ".m3u" ' = Ausgabedatei
Set oFS = CreateObject("Scripting.FileSystemObject")
Set m3uFile=oFS.CreateTextFile(m3ufile, 1) ' Ausgabedatei öffnen
Set oFile = oFS.GetFile(fname)
Set oM3U = oFile.OpenAsTextStream
m3uFile.WriteLine("#EXTM3U") ' Den Anfang einer .m3u Datei schreiben
anzfiles=anzfiles + 1 ' zähle die Anzahl der .b4s Dateien
Ordner="":Song="":Laenge="" ' Was ich jetzt öfter belege, initialisieren

do while not oM3U.AtEndOfStream ' .b4s Datei lesen und .m3u Datei erstellen
sMP3 = oM3U.ReadLine
If IsinStr("<entry Playstring=", sMP3)= True Then Ordner = stripfromxml(sMP3,"<entry Playstring=",">")
if IsinStr("<Name>", sMP3)= True Then Song = stripfromxml( sMP3,"<Name>","</Name>")
if IsinStr("<Length>", sMP3)= True Then Laenge = stripfromxml( sMP3,"<Length>","</Length>")

' Die 3 relevanten Daten werden aus der .b4s (XML)Datei extrahiert
' und den Variablen Song,Ordner,Laenge übergeben
If Song <> "" And Laenge <> "" Then
Song = HtmlDecode(Song) ' Sonderzeichen der XML .b4s Datei dekodieren

m3uFile.WriteLine "#EXTINF:" & Laenge & ","& Song
Song="" : Laenge = ""
If Ordner <> "" Then
Ordner = Mid(Ordner,2,Len(Ordner)-2)
Ordner = HtmlDecode(Ordner) ' Sonderzeichen der XML .b4s Datei dekodieren
m3uFile.WriteLine Ordner
Ordner=""
End If
End If
Loop

m3uFile.Close
End Sub ' convertFile(fname)


'*********************************************************
Function stripfromxml (xmlstring,xmlpart1,xmlpart2)
'*********************************************************
Dim pos1,pos2,thename
thename=""

pos1 = instr(xmlstring,xmlpart1)
If pos1 Then
thename = mid(xmlstring,pos1+len(xmlpart1),Len(xmlstring))
End If
pos2 = instr(thename,xmlpart2)
If pos2 then thename = mid(thename,1,(pos2)-1)
If xmlpart1="<Length>" then thename = striplastzeroes(thename) ' Länge wird mit 6 Ziffern angegeben, deshalb letzte Nullen löschen
stripfromxml = thename ' das kann zu falschen Songlängen führen. siehe unten.
End Function ' stripfromxml (xmlstring,xmlpart1,xmlpart2)


'*********************************************************
Function BrowseForFile(strPrompt,strtitle)
'*********************************************************
'Benutzt die "Shell.Application" (nur anzutreffen in Win98 and neuer)
'um das Datei/Ordner Fenster aufzurufen. Nicht unter Win95.
'Shell32.ShellSpecialFolderKonstanten
Const ssfPERSONAL = 5 'Meine Dokumente
Const ssfDRIVES = 17 'Mein Computer
Const SFVVO_SHOWALLOBJECTS = 1
Const SFVVO_SHOWEXTENSIONS = 2
Const SFVVO_SHOWFILES = 16384
Dim sh, fol, fs, lngView, strPath,i
Set sh = CreateObject("Shell.Application")
If Instr(TypeName(sh), "Shell") = 0 Then
BrowseForFile = InputBox(strPrompt, strtitle, CreateObject("Scripting.FileSystemObject").GetParentFolderName(WScript.ScriptFullName) & "Pfad\Dateiname")
Exit Function
End If
Set fs = CreateObject("Scripting.FileSystemObject")
lngView = SFVVO_SHOWALLOBJECTS Or SFVVO_SHOWEXTENSIONS Or SFVVO_SHOWFILES
strPath = ""
Set fol = sh.BrowseForFolder(&0, strPrompt, lngView, ssfDRIVES)
On Error Resume Next
strPath = fol.ParentFolder.ParseName(fol.Title).Path
If strPath = "" Then
strPath = fol.Title
Set fol = fol.ParentFolder
strPath = fs.BuildPath(fol.ParentFolder.ParseName(fol.Title).Path, strPath)
i = InStr(strPath, ":")
strPath = Mid(strPath, i - 1, 1) & ":\" ' Nur Laufwerk:\ zurückgeben
End If
BrowseForFile = strPath
End Function ' BrowseForFile(strPrompt,strtitle)


'*********************************************************
Function IsinStr(muster, zkette)
'*********************************************************
Dim regEx, retVal ' Variablen,die ich brauche.
Set regEx = New RegExp ' Regulären Ausdruck erstellen.
regEx.Pattern = muster ' Setze Muster.
regEx.IgnoreCase = True ' Groß-Kleinschreibung ausschalten.
retVal = regEx.Test(zkette) ' Führe Durchsuchung aus.
if retVal Then IsinStr = True Else IsinStr = False
End Function ' IsinStr(muster, zkette)


'*********************************************************
public Function HtmlDecode( sText)
'*********************************************************
'Wie in HTML müssen auch in XML Sonderzeichen speziell formatiert werden. Die fünf Zeichen &, ', <, > und "
'werden wie in HTML angegeben:
' ' hex ´ oder '
' & &
' < <
' > >
' " "

'Umlaute und das ß müssen aber so definiert werden:

' Ä Ä hex c4
' Ö Ö hex d6
' Ü Ü hex dc
' ä ä hex e4
' ö ö hex f6
' ü ü hex fc
' ß ß hex df
' € € hex 20ac
' Alles dies erledigt die Function HtmlDecode

sText = Replace(sText, "Ä", "Ä")
sText = Replace(sText, "Ö", "Ö")
sText = Replace(sText, "Ü", "Ü")
sText = Replace(sText, "ä", "ä")
sText = Replace(sText, "ö", "ö")
sText = Replace(sText, "ü", "ü")
sText = Replace(sText, "ß", "ß")
sText = Replace(sText, "€", "€")
sText = Replace(sText, "?", "'")
sText = Replace(sText, "<", "<")
sText = Replace(sText, ">", ">")
'sText = Replace(sText, """, """")
sText = Replace(sText, "$", "$")
sText = Replace(sText, "&", "&")
sText = Replace(sText, "´", "'")
sText = Replace(sText, """, """")
sText = Replace(sText, " ", " ")
sText = Replace(sText, "&bsp;", " ")
HtmlDecode = sText
End Function ' HtmlDecode( sText)


'*********************************************************
Function striplastzeroes(strNumber)
'*********************************************************
' Es kann sein, dass die Songlänge nicht richtig angegeben wird; denn
' in .b4s Playlisten werden 6 Ziffern für die Dateilänge verwendet.
' Ist ein Song 1000 Sekunden lang wird er nach der striplastzeroes Funktion
' auf 100 Sekunden gekürzt. Das ist jedoch nicht so schlimm, wie es scheint,
' da Winamp die falsche Songdauer automatisch korrigert.
Dim MyLong1
MyLong1 = CLng(strNumber)
If (MyLong1 mod 1000) <> 0 Then
striplastzeroes = CStr(Mylong1/100)
Else
striplastzeroes = CStr(Mylong1/1000)
End If

End Function ' striplastzeroes(strNumber)




http://dieseyer.de • all rights reserved • © 2011 v11.4