http://dieseyer.de • all rights reserved • © 2011 v11.4
'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 *******************************************
http://dieseyer.de • all rights reserved • © 2011 v11.4