Unterordner auf Basis eines Teils des Dateinamens erstellen - Dateien da rein verschieben

::--------Snipp SortDir.bat
@echo off & setlocal EnableDelayedExpansion
If [%1]== %0 *.*
If [%2]== %0 %1 254
Echo %0:...gesetzte Parameter sind Dateifilter: [%1] Länge: [%2]
For /f %%i in ('dir /A:-d /b %1 %2') do (  
       set "tmpv=%%i"  
       echo Datei [%%i] soll in Verzeichnis [!tmpv:~0,%2!]
       If not exist "!tmpv:~0,%2!" ECHO ..existiert nicht... md !tmpv:~0,%2!  
       If     exist "!tmpv:~0,%2!" ECHO ..verschiebe..        move !tmpv:~0,%2!%1 !tmpv:~0,%2!  
)       
::--------Snapp SortDir.bat
goto :eof

'Sortiert Dateien in Unterverzeichnisse  

Set WSHShell = WScript.CreateObject("WScript.Shell")  
Set fso      = WScript.CreateObject("Scripting.FileSystemObject")  
set oArgs    = Wscript.Arguments 

If oArgs.Count > 0 Then                      ' gibt es Argumente?   
  Pfad = oArgs.item(0)                       ' erstes Argument   

  if fso.FileExists( Pfad ) then Pfad = fso.GetParentFolderName( Pfad ) 
     ' obige Zeile wird nur ausgeführt, wenn "Pfad" eine Datei ist  

Else                                         ' es gibt keine Argumente!  
  Pfad = fso.GetFolder( "." )                ' Verzeichnis, in dem sich das Skript befindet  
End If 
 
if not fso.FolderExists( Pfad ) then
  MsgBox UCase(Pfad) & "   existiert nicht!" & vbCRLF & vbCRLF & " . . . das ist das Ende.", , WScript.ScriptName  
  WScript.Quit
End If

'	DFilte = "*.*"	bisher ungenutzt  
	Laenge = 4		'später über InputBox oder Argument  
'	Anzahl = 5		bisher ungenutzt  


' Dateiliste an Array übergeben  
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  
i = 0
Set oFolders = fso.GetFolder( Pfad )  
Set oFiles   = oFolders.Files
  For Each DateiX In oFiles
    ReDim Preserve Datei(i)
                   Datei(i) = DateiX.Name 
    i = i + 1
  Next
Set oFiles   = nothing
Set oFolders = nothing

'Verarbeitung  
If i > 0 then                                ' wenn es Datei(en) gibt   
  For i = 0 to UBound( Datei )
	NPfad = Left(Datei(i),Laenge)
	If (fso.FolderExists(NPfad)) Then
		fso.MoveFile Datei(i), Pfad & "\" & NPfad & "\"  
	else
		fso.CreateFolder Pfad & "\" & NPfad  
		fso.MoveFile Datei(i), Pfad & "\" & NPfad & "\"  
	end if
  Next
End If

  For i = 0 to UBound( Datei )
	NPfad = Trim(Left(Datei(i),Laenge))
	ReDim Preserve UPfad(i)
	               UPfad(i) = NPfad
  Next

  FZaehler = 0
  y = 0
  XPfad = LCase(UPfad(y))
  For i = 0 to UBound( UPfad )
	if LCase(UPfad(i)) = XPfad then
		FZaehler = FZaehler + 1
	else
		ReDim Preserve YPfad(y)	
		               YPfad(y) = XPfad
		ReDim Preserve YZaehl(y)
		               YZaehl(y) = FZaehler
		XPfad = LCase(UPfad(i))
		FZaehler = 1
		y = y + 1
	end if
  Next
'fuers letzte Verzeichnis  
  If FZaehler > 1 then
		ReDim Preserve YPfad(y)	
		               YPfad(y) = XPfad
		ReDim Preserve YZaehl(y)
		               YZaehl(y) = FZaehler
		y = y + 1
  end if

For y = 0 to UBound( YPfad )
	if YZaehl(y) >= Anzahl then
		If (fso.FolderExists(Pfad & "\" & YPfad(y))) = false Then  
			fso.CreateFolder Pfad & "\" & YPfad(y)  
		end if
	end if
Next

For i = 0 to UBound( Datei )
	If (fso.FolderExists(UPfad(i))) Then
		if (fso.FileExists(Pfad & "\" & UPfad(i) & "\" & Datei(i))) = false then  
			fso.MoveFile Pfad & "\" & Datei(i), Pfad & "\" & UPfad(i) & "\"  
		end if
	end if
Next

'Sortiert Dateien in Unterverzeichnisse  
Dim Log 


Set WSHShell = WScript.CreateObject("WScript.Shell")  
Set fso      = WScript.CreateObject("Scripting.FileSystemObject")  
Set oArgs    = Wscript.Arguments 



If oArgs.Count > 0 Then 
  Pfad = oArgs.item(0)                       ' erstes Argument   

  if fso.FileExists( Pfad ) then Pfad = fso.GetParentFolderName( Pfad ) 
     ' obige Zeile wird nur ausgeführt, wenn "Pfad" eine Datei ist  

else 
	Pfad = OrdnerWahl()
end if

if not fso.FolderExists( Pfad ) then
  MsgBox UCase(Pfad) & "   existiert nicht!" & vbCRLF & vbCRLF & " . . . das ist das Ende.", , WScript.ScriptName  
  WScript.Quit
End If

'	DFilte = InputBox("Bitte geben Sie einen Dateifilter an!","Dateifilter","*.*")  
'Bis jetzt keine mit vernünftigem Aufwand realisierbare Variante gefunden  

	Laenge = InputBox("Bitte geben Sie die Anzahl der zu berücksichtigenden Zeichen des Dateinamens an!","Dateifilter",8)  
	If Laenge = "" Then  
	 	WScript.Quit
	ElseIf IsNumeric(Laenge) = False then
		WScript.Quit
	ElseIf Laenge > 256 then
		WScript.Quit
	Else
		Laenge = CByte(Laenge)
	End If
	Anzahl = InputBox("Bitte geben Sie die Mindestanzahl an Dateien an!","Dateifilter",11)  
	If Anzahl = "" Then  
	 	WScript.Quit
	ElseIf IsNumeric(Anzahl) = False then
		WScript.Quit
	ElseIf Anzahl > 256 then
		WScript.Quit
	Else
		Anzahl = CByte(Anzahl)
	End If
	Log    = MsgBox("Logdatei erstellen?", vbYesNo, "Logging")  
 
' Dateiliste an Array übergeben  
' -----------------------------  
i = 0
Set oFolders = fso.GetFolder( Pfad )  
Set oFiles   = oFolders.Files
  For Each DateiX In oFiles
    ReDim Preserve Datei(i)
                   Datei(i) = DateiX.Name 
    i = i + 1
  Next
Set oFiles   = nothing
Set oFolders = nothing
If i = 0 then
  MsgBox "Keine Dateien in " & UCase(Pfad) & vbCRLF & vbCRLF & " . . . das ist das Ende.", , WScript.ScriptName  
  WScript.Quit
End If

'Log HTML starten  
'---------------  
if Log = 6 then
	if month(now)<10 then Monat = "0" & month(now) else Monat = month(now)  
	if day(now)<10 then Tag = "0" & day(now) else Tag = day(now)  
	if hour(now)<10 then Stunde = "0" & hour(now) else Stunde = hour(now)  
	if minute(now)<10 then Minuten = "0" & minute(now) else Minuten = minute(now)  
	Dateiname = "SortDir " & year(now) & "-" & Monat & "-" & Tag & "h" & Stunde & "m" & Minuten  
	LogDatei = HTMLKopf(Pfad, Dateiname, Laenge, Anzahl, i)
end if

'Muster : if Log = 6 then HTMLLog LogDatei, "Ordner", "mag ich nicht sagen", "erstellt"  



'Array mit dem zukünftigen Pfad bilden  
'-------------------------------------  
' hier könnte man noch eine Syntaxkontrolle einbauen  

  For i = 0 to UBound( Datei )
	NPfad = Trim(Left(Datei(i),Laenge))
	ReDim Preserve UPfad(i)
	               UPfad(i) = NPfad
  Next

'Neues Array mit dem Pfad und eines Mit der Anzahl der Dateien bilden  
'--------------------------------------------------------------------  
  FZaehler = 0
  y = 0
  XPfad = UPfad(y)
  For i = 0 to UBound( UPfad )
	if StrComp(UPfad(i), XPfad , 1) = 0 then
		FZaehler = FZaehler + 1
	else
		ReDim Preserve YPfad(y)	
		               YPfad(y) = XPfad
		ReDim Preserve YZaehl(y)
		               YZaehl(y) = FZaehler
		XPfad = UPfad(i)
		FZaehler = 1
		y = y + 1
	end if
  Next
'fuers letzte Verzeichnis  
  If FZaehler > 1 then
		ReDim Preserve YPfad(y)	
		               YPfad(y) = XPfad
		ReDim Preserve YZaehl(y)
		               YZaehl(y) = FZaehler
		y = y + 1
  end if

'Ordner erstellen wenn die Mindestanzahl an Dateien erfüllt ist  
'--------------------------------------------------------------  
For y = 0 to UBound( YPfad )
	if YZaehl(y) >= Anzahl then
		If (fso.FolderExists(Pfad & "\" & YPfad(y))) = false Then  
			fso.CreateFolder Pfad & "\" & YPfad(y)  
			if Log = 6 then HTMLLog LogDatei, "Ordner", YPfad(y), "<font color=green>Verzeichnis erstellt</font>"  
		else
			if Log = 6 then HTMLLog LogDatei, "Ordner", YPfad(y), "<font color=red>nicht erstellt: Verzeichnis bereits vorhanden</font>"  
		end if
	else
'		if Log = 6 then HTMLLog LogDatei, "Ordner", YPfad(y), "nicht erstellt: nur " & YZaehl(y) & " Dateien"  
	end if
Next

'Verschieben der Dateien falls ein Ordner existiert  
'--------------------------------------------------  
'Ich nehme absichtlich das alte Dateilisting, damit eine evtl. Logdatei oder zwischenzeitlich hinzu gekommene Dateien nicht angefasst werden  
'UPfad wird deswegen an Stelle von Len(Datei(i),Laenge) verwendet damit evtl. syntaxkorrekturen berücksichtigt werden  
For i = 0 to UBound( Datei )
	If (fso.FolderExists(Pfad & "\" & UPfad(i))) Then  
		if (fso.FileExists(Pfad & "\" & UPfad(i) & "\" & Datei(i))) = false then  
			fso.MoveFile Pfad & "\" & Datei(i), Pfad & "\" & UPfad(i) & "\"  
			if Log = 6 then HTMLLog LogDatei, "Datei", Datei(i), "<font color=green>verschoben nach: " & UPfad(i) & "</font>"  
		else
			if Log = 6 then HTMLLog LogDatei, "Datei", Datei(i), "<font color=red>bereits im Unterordner <b>" & UPfad(i) & "</b> vorhanden</font>"  
		end if
	else
'		if Log = 6 then HTMLLog LogDatei, "Datei", Datei(i), "nicht verschoben"  
	end if
Next

'Log HTML beenden  
'---------------  
if Log = 6 then
	HTMLFuss LogDatei
end if

Set WSHShell = nothing
Set fso      = nothing
Set oArgs    = nothing

WScript.Quit

function OrdnerWahl()
'Zeigt den Select Folder Dialog an  
	set shell = CreateObject("Shell.Application")  
	AuswahlTitel = "Geben Sie das Verzeichnis an in dem Sortiert werden soll"  
	StartOrdner = 17
	Set retVal = shell.BrowseForFolder(0,AuswahlTitel, &H200,StartOrdner)
	set parent = retVal.ParentFolder
	set Rpath = parent.items
	for each item in Rpath
		if item.Name = retVal.Title then PfadName = item.Path
	next
	OrdnerWahl = PfadName
	set shell = nothing
	set retVal = nothing
	set parent = nothing
	set RPath = nothing
end function

function HTMLKopf(Pfad, Dateiname, Laenge, Anzahl, Dateianzahl)
'erstellt die Logdatei und erfasst die Kopfdaten der HTML-Datei.  
'Gibt die Datei zurück falls Änderungen auftreten sowie für die übrigen HTML-Funktionen  
	Endung = ".htm"  
	sPath = Pfad & "\" & Dateiname & Endung  
	d = 1
	do while fso.FileExists( sPath )
		Dateiname = Dateiname & "-" & d  
		sPath = Pfad & "\" & Dateiname & Endung	  
		d = d + 1
	loop
	Set LogFile = fso.OpenTextFile(sPath, 8, true, -2)
	LogFile.Write("<html>" & vbCrLf & "<head>" & vbCrLf & "<title>LogFile SortDir-Skript</title>" & vbCrLf & "</head>" & vbCrLf & _  
			"<body>" & vbCrLf & "<h3>&Uuml;bergebene Parameter:</h3>" & vbCrLf & "<table bolder=0>" & vbCrLf & _  
			"<tr><td align=right><b>Pfad:&nbsp;</b></td><td>" & Pfad & "</td></tr>" & vbCrLf & _  
			"<tr><td align=right><b>Filter:&nbsp;</b></td><td>" & "*.* (derzeit nicht anders M&ouml;glich)" & "</td></tr>" & vbCrLf & _  
			"<tr><td align=right><b>Zeichen des Dateinamens:&nbsp;</b></td><td>" & Laenge & "</td></tr>" & vbCrLf & _  
			"<tr><td align=right><b>Mindestanzahl der Dateien:&nbsp;</b></td><td>" & Anzahl & "</td></tr>" & vbCrLf & _  
			"<tr><td align=right><b>Anzahl zu pr&uuml;fender Dateien:&nbsp;</b></td><td>" & Dateianzahl & "</td></tr>" & vbCrLf & _  
			"</table>" & vbCrLf & "<p>Folgende &Auml;nderungen wurden vorgenommen:</p>" & vbCrLf & "<table border=1 width=90% align=center>" & vbCrLf & _  
			"<tr><th>Zeit</th><th>Typ</th><th>Name</th><th>Ereignis</th></tr>" & vbCrLf & _  
			"<tr><td align=center>" & now & "</td><td colspan=2 align=center>&nbsp;</td><td>Lauf-Beginn</td></tr>" & vbCrLf)  
	LogFile.close
	set LogFile = nothing
	HTMLKopf = sPath
end function

function HTMLLog(LogDatei, Typ, Name, Ereignis)
'erfasst einen Tabelleneintrag der HTML-Datei.  
	Set LogFile = fso.OpenTextFile(LogDatei, 8, true, -2)
	LogFile.Write("<tr><td align=center>" & now & "</td><td align=center>" & Typ & "</td><td>" & Name & "</td><td>" & Ereignis & "</td></tr>" & vbCrLf)  
	LogFile.close
	set LogFile = nothing
end function

function HTMLFuss(LogDatei)
'erfasst die Fußdaten der HTML-Datei.  
	Set LogFile = fso.OpenTextFile(LogDatei, 8, true, -2)
	LogFile.Write("<tr><td align=center>" & now & "</td><td colspan=2 align=center>&nbsp;</td><td>Lauf-Ende</td></tr>" & vbCrLf & _  
			"</table></body></html>")  
	LogFile.close
	set LogFile = nothing
end function