'v5.6************************************************************************************* ' File: changefilenames-imag0001.vbs ' Autor: Peter Ladnar, erweitert von Michael Wende ' ' Beschreibung: ' Digitale Bilddateien einer Digicam eines bestimmten Verz. umbennen und neu durchnummerieren ' ' Meine Version geht davon aus, dass die Bilddateien im Digicam Ordner von verschiedenen ' Anlässen, wie Geburtstag, Gartenparty, Urlaub e.t.c. als z.B IMAG0001 bis IMAG0144 vorliegen, ' wobei z.B. IMAG0001 - IMAG0012 Bilddateien vom Geburtstag sind. ' IMAG0013 - IMAG0025 Bilddateien von einer Gartenparty u.s.w. ' Nun können diese Bilddateien eindeutig umbenannt werden. Das Skript ändert bei z.B. Eingabe ' von "0013 - 0025" und "Gartenparty Sommer" die Dateien IMAG0013 - IMAG0025 in ' "Gartenparty Sommer0001" - "Gartenparty Sommer0013" um. ' '***************************************************************************************** ' Zum Debuggen: script //d name.vbs stop ' Start des Hauptprogrammes ************************************************************** Dim strNewName, objPath, intValue,start,ende,z Dim songtab(),startzahl,endzahl,h,VonBis,i Dim ausgabetab(),leni,lenh1,isda strNewName = Empty FolderAuswahl VonBis = InputBox ("Von welcher Datei bis zu welcher Datei umbenennen?","Bitte Ziffern innerhalb der eckigen Klammern max 4stellig eintragen","[0001] - [0012]") If VonBis = "" Then WScript.Quit ' Hole Start und Endwert als Cstr start = Mid(VonBis,2,4) ende = Mid(VonBis,11,4) ' Führende "0" en werden ausgefiltert startzahl= TrimleadingZeroes(start) endzahl = TrimleadingZeroes(ende) ' Tabellen mit Werten füllen. ' Die songtab() Tabelle nimmt die Vergleichswerte auf, während die ausgabetab() Tabelle die ' Änderungswerte aufnimmt. ' Beispiel: Geändert werden sollen die Fotodateien Imag0007 - Imag0010 ' in BildervonLisa. ' Das Programm erstellt dann BildervonLisa0001 - BilderVonLisa0004 ' Gesucht werden Dateiendungen 0007 - 0010 = songtab() Werte ' Geändert werden die Dateien in 0001 - 0004 = ausgabetab() Werte. For i = Cint(startzahl) To Cint(endzahl) h = CInt(i) - CInt(startzahl) leni = Len(i) lenh1 = Len(h+1) ReDim Preserve songtab(h+1) ReDim Preserve ausgabetab(h+1) Select Case leni Case 1 songtab(h) = "000" & CStr(i) Case 2 songtab(h) = "00" & CStr(i) Case 3 songtab(h) = "0" & CStr(i) Case Else songtab(h) = CStr(i) End Select Select Case lenh1 Case 1 ausgabetab(h) = "000" & CStr(h+1) Case 2 ausgabetab(h) = "00" & CStr(h+1) Case 3 ausgabetab(h) = "0" & CStr(h+1) Case Else ausgabetab(h) = CStr(h+1) End Select Next ShowFolderList objPath ' Hier wird der neue Name eingegeben For z = Lbound(songtab) to Ubound(songtab)-1 ' Dateien suchen und ändern ShowFileList objPath,songtab(z),ausgabetab(z) Next MsgBox "Alle Dateien umbenannt, fertig ",0,"Digi-Photo Tool, Ende" ' Ende des Hauptprogrammes ***************************************************************** ' Start Sub Routinen und Funktionsbeschreibungen ******************************************* Sub FolderAuswahl isda = EintraginsKontextmenue() If isda = True then objPath = CurrentDir ' Für die Einbindung ins Kontextmenü des Windows Explorers. else objPath = BrowseForFolder("Ordner mit Bildern auswählen:",&h1, "C:\Eigene Dateien") End If End Sub Sub ShowFolderList(folderspec) Dim s, x,k x = 0 s = objPath & ":" & vbCrLf & vbCrLf For k = Lbound(songtab) to Ubound(songtab)-1 If (x < 10) Then s = s & songtab(k) s = s & vbCrLf x = x+1 End If Next If (x = 0) Then MsgBox "Verzeichnis enthält keine Dateien !! ",0, WScript.Scriptname & " - Ende" WScript.Quit End If s = s & "..." & vbCrLf & "Dateien mit diesem Mustertyp und alle anderen Dateien umbenennen in:" strNewName = InputBox (s,WScript.Scriptname & " - Neuer Dateiname","Neuen Namen eingeben") If (IsEmpty(strNewName) = True) Then WScript.Quit End If End Sub Sub ShowFileList(folderspec,suchmuster,renmuster) Dim fs, f, f1, fc, zahl Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder(folderspec) Set fc = f.Files For Each f1 in fc If IsinStr(suchmuster, f1) = True Then RenameFile f1, renmuster Exit For End If Next End Sub 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 Function RenameFile(fileName, x) Dim objFSO, strDest, strName, strExt, strMessage,intValue strName = "\" & strNewName & x strExt = Lcase(right(fileName,4)) Select Case strExt Case ".jpg",".bmp",".gif",".tif" intValue = 6 Case Else strMessage = fileName & vbCrLf & "ist keine Bilddatei, trotzdem umbennen?" intValue = MsgBox(strMessage,4,WScript.Scriptname & " - Keine Bilddatei") End Select If (intValue = 7) Then Exit Function End If Set objFSO = CreateObject("Scripting.FileSystemObject") strDest = objPath & strName & strExt ' If ExistFile(strDest) = False then objFSO.CopyFile fileName , strDest , OverWriteFiles objFSO.DeleteFile fileName ' End If End Function Function BrowseForFolder(strPrompt, BrowseInfo, root) On Error Resume Next Dim objShell, objFolder, intColonPos, objWshShell, returnerror Set objShell = WScript.CreateObject("Shell.Application") Set objWshShell = CreateObject("WScript.Shell") Set objFolder = objShell.BrowseForFolder(&H0, strPrompt, BrowseInfo, root) BrowseForFolder = objFolder.ParentFolder.ParseName(objFolder.Title).Path returnerror = err.number If returnerror <> 0 Then If returnerror = 424 then BrowseForFolder = Null else intColonPos = InStr(objFolder.Title, ":") If intColonPos > 0 Then BrowseForFolder = Mid(objFolder.Title, intColonPos - 1, 2) & "\" End If End If End If End Function Function ExistFile(files) Dim fio, msg Set fio = CreateObject("Scripting.FileSystemObject") If (fio.FileExists(files)) Then ExistFile = True Else ExistFile = False End If End Function Function CurrentDir Dim newfso Set newfso = WScript.CreateObject("Scripting.FileSystemObject") CurrentDir = newfso.GetAbsolutePathName(".") End Function Function TrimleadingZeroes(mystring) Dim ind,helpme,erg erg="" helpme="" For ind = 1 To Len(mystring) helpme = Mid(mystring,ind,1) If helpme <> "0" Then erg = erg + helpme If Len(erg) >= 1 And helpme = "0" Then erg = erg + "0" Next TrimleadingZeroes = erg End Function Function EintraginsKontextmenue() dim WSHShell, KeyNew, path, kontext,m,asatz dim KeyToo,Eintrag Set WSHShell =WScript.CreateObject ("WScript.Shell") path = WScript.ScriptFullName kontext = "Bilder umbenennen" EintraginsKontextmenue = False KeyNew="HKCR\AllFilesystemObjects\shell\" & kontext & "\command\" If WSHShell.RegRead(KeyNew) = "" then Eintrag = InputBox ("Möchten Sie dieses Skript ins Kontextmenü des Explorers einbinden?",vbYesNo) If Eintrag = vbYes then WSHShell.RegWrite KeyNew,"wscript " & path EintraginsKontextmenue = True MsgBox("Eintrag als *" & kontext & "* wurde neu angelegt.") End If Else EintraginsKontextmenue = True end if End Function ' Ende Sub Routinen und Funktionsbeschreibungen *******************************************