Wave Files aus Verzeichnis in XML-Liste

<nohtml> '* Author * Me '* Email_Address * me@home.com '* Script_Type * Vbscript '* Sub_Type * Files/FileSystem '* Keywords * XML, drives, folder, FileSystemObject 'Kommentar 'Ein Verzeichnis wird abgefragt und eine XML-Datei listet die Inhalte auf '~~Script~~. '************************************************************** '* Verzeichnislistenscript für XML '* Design und Code von Mark Krüger '* '* Stand: 1. Mai. 2015 '* '* Hinweis '* '* 1) Die Source- u. Ziel-Verzeichnisse werden abgefragt und eine XML-Datei listet die '* Dateinamen aller enthaltenen WAV-Dateien auf '* '* 2) Der Benutzer wird durch die Umgebungsvariable "USERNAME" '* festgestellt und ist als Author in der XML-Datei '* '* 3) Die Datei wird als [Titel].xml erstellt + im Browser gestartet '* '************************************************************** Option Explicit Public WSHShell, fso, fh1, fh2, fh3, fh4, fh5 Dim intIndex,replTxt,regExpr,replStr,prvTxt,strEnv,netzname Set regExpr = New RegExp Public Dir, filcnt Public strDirDoneTxt Public strMsgTitle, doktitel, wavdir Public strInput, strRunit Public IExec, strTarget Public AnzFiles, sumFileSize, author Public oFolder,oFolders,oFiles,item,Item2,Tastenfarbe,intCounter 'Ersteller feststellen Set WSHShell = WScript.CreateObject("WScript.Shell") For Each strEnv In WshShell.Environment("PROCESS") intIndex = intIndex + 1 If left(strEnv,8)="USERNAME" Then author=right(strEnv,len(strEnv)-9) End if Next '*** Erstellt das FileSystem Object Set fso = CreateObject("Scripting.FileSystemObject") strInput= InputBox("Verzeichnis der .wav Dateien:", "Directory-Liste als XML-Datei",fso.GetAbsolutePathName(".")) dir = strInput if fso.FolderExists(dir) = False then strDirDoneTxt = dir & vbcr & "Verzeichnis existiert nicht!" strMsgTitle = "Eingabefehler" prvTxt = MsgBox(strDirDoneTxt, vbOKOnly + vbCritical, strMsgTitle ) WScript.Quit end if ' === DOKUMENTENTITEL festlegen ========================== wavdir = fso.GetAbsolutePathName(".") wavdir = fso.GetFileName(wavdir) doktitel = InputBox("Kategorie der .wav Dateien:", "Name (Titel)",wavdir) ' Zieldatei -- wird mit Name(Titel) Kategorie - Abfrage erweitert strTarget = ".xml" ' ============================================================================================ ' === SUBROUTINE starten, um Dateianzahl zu ermitteln !========================== GetFiles dir AnzFiles = filcnt-1 filcnt = 0 ' ============================================================================================ set fh1=fso.createTextFile(strInput & strTarget) fh1.WriteLine("<?xml version=""1.0"" ?>") fh1.close strDirDoneTxt ="XML Liste fertig!" strMsgTitle = "XML Verzeichnis Liste." ' === HAUPT-SUBROUTINE ========================== GetDir dir ' =============================================== set fh5=fso.openTextFile(strInput & strTarget,8) fh5.WriteLine("</keys>") fh5.WriteLine("<author=""" & author & """>") fh5.WriteLine("<folder = " & chr(34) & ofolder & chr(34) & " />") fh5.WriteLine("<files=""" & filcnt-1 & """ />") fh5.close '*** Internet Explorer startet mit Zieldatei Set IExec = CreateObject("InternetExplorer.Application") strRunit = strInput & strTarget IExec.navigate strRunit IExec.visible=1 '*** Ende des Scripts WScript.Quit ' === SUBROUTINES FOLLOW ========================== '---------------------- sub GetFiles(dir) set oFolder=fso.GetFolder(dir) set oFolders=oFolder.SubFolders set oFiles=oFolder.Files '*** Für alle Unterverzeichnisse des angegebenen Ordners For each item in oFolders 'go to each one GetFiles(item) Next filcnt = filcnt +1 item2=0 For each item2 in oFiles filcnt = filcnt +1 next end sub '---------------------- sub GetDir(dir) set oFolder=fso.GetFolder(dir) set oFolders=oFolder.SubFolders set oFiles=oFolder.Files '*** Für alle Unterverzeichnisse des angegebenen Ordners 'For each item in oFolders '*** go to each one ' GetDir(item) 'Next '*** Zieldatei öffnen set fh4=fso.openTextFile(strInput & strTarget,8) '*** Kopf fh4.WriteLine("<keys name=""" & doktitel & """>") '*** Basisverz. vom Ordnernamen abschneiden fh4.WriteLine(right(ofolder,len(ofolder)-len(strInput))) fh4.close filcnt = filcnt +1 item2=0 '*** Anzahl der .wav Files feststellen, da letzte Taste nicht schwarz sein soll For each item2 in oFiles If UCase(fso.GetExtensionName(item2.name)) = "WAV" Then intCounter = intCounter + 1 next '*** Um keine Dateien aufzulisten Kommentar vor (fh3.WritLine...) setzen! '*** und bei der if Schleife Kommentar entfernen! For each item2 in oFiles If UCase(fso.GetExtensionName(item2.name)) = "WAV" Then set fh3=fso.openTextFile(strInput & strTarget,8) '*** Summe für abweichende Durchschnitte sumFileSize = sumFileSize + item2.size '---------------------- 'Tastenfarbe festlegen if Tastenfarbe = "black" or item2.size < (sumFileSize / filcnt +1) or filcnt = intCounter then '*** ZEILE schreiben Tastenfarbe = "white" 'Tastenfarbe im Piano fh3.Write(" <white label=" & chr(34)) '& item2.size & " < " & (sumFileSize / filcnt +1) & " " & filcnt & "=" & intCounter else '*** ZEILE schreiben Tastenfarbe = "black" 'Tastenfarbe im Piano fh3.Write(" <black label=" & chr(34)) '& item2.size & " < " & (sumFileSize / filcnt +1) & " " & filcnt & "=" & intCounter end if '*** Sonderzeichen in Beschriftung entfernen replStr = "" regExpr.IgnoreCase = True regExpr.Global = True regExpr.Pattern = "[^0-9A-z]" '*** NUR Buchstaben + Zahlen replTxt = regExpr.Replace(left(item2.Name,5), replStr) 'msgbox chr(34) & mid(replTxt,5,1) & chr(34),vbokonly,filcnt & replTxt & chr(34) & " len=" & len(replTxt) if len(replTxt) < 5 then replTxt = left(replTxt & replTxt,5) if replTxt = prvTxt then replTxt = left(replTxt,4) & chr(asc(mid(replTxt,5,1))+1) fh3.Write(replTxt & chr(34)) 'Tastenbeschriftung im Piano fh3.WriteLine(" music=""" & wavdir & "\" & item2.Name & chr(34) & "/>") 'Verzeichnis + Dateiname 'if left(item2.Name,1) = "." then ' fh3.WriteLine(item2.Name) 'end if fh3.close filcnt = filcnt +1 prvTxt = replTxt End If next '*** Zeile abschliessen set fh4=fso.openTextFile(strInput & strTarget,8) 'fh4.WriteLine("
") fh4.close end sub '***---------------------- Sub CreateIE(sOpenPage, pLeft,pTop, pWidth,pHeight) Set IExec = CreateObject("InternetExplorer.Application") IExec.left = pLeft IExec.top = pTop IExec.height = pHeight IExec.width = pWidth IExec.menubar = 0 IExec.toolbar = 0 IExec.statusbar = 0 IExec.navigate sOpenPage IExec.visible=1 ' wait for page to load while IExec.Busy: WScript.Sleep(50): wend End Sub </nohtml>