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

'v3.5***************************************************
' File: changefilenames.vbs
' Autor: Peter Ladnar
' dieseyer.de
'
' Bilddateien eines Verz. umbennen und durchnummerieren
'*******************************************************
' zum debugen: script //d name.vbs stop

Dim strNewName, objPath, intValue

strNewName = Empty
Begruessung()
FolderAuswahl
ShowFolderList objPath
ShowFileList objPath
MsgBox "Alle Dateien umbenannt, fertig ",0,"Digi-Photo Tool, Ende"


Function Begruessung()
Dim intValue, strMessage
strMessage = "Du hast auch eine digitale Kamera und dich nervt es auch, die Dateinamen" & vbCrLf
strMessage = strMessage & "mühselig manuell in sinnvolle Namen zu ändern?" & vbCrLf & vbCrLf
strMessage = strMessage & "Dann ist dieses Tool genau richtig für dich! "
strMessage = strMessage & "Es benennt alle Dateien eines" & vbCrLf & "wählbaren Verzeichnisses "
strMessage = strMessage & "in einen neuen, durchnummerierten Namen um." & vbCrLf & vbCrLf
strMessage = strMessage & "Tool starten ?"
intValue = MsgBox(strMessage,4, WScript.Scriptname & " - Begrüssung")
If (intValue = 7) Then
WScript.Quit
End If
End Function

Sub FolderAuswahl
Const WINDOW_HANDLE = 0
Const NO_OPTIONS = 0
Const OverWriteFiles = True
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder (WINDOW_HANDLE, "Ordner mit Bildern auswählen:", NO_OPTIONS, "C:\ d:\")
Set objFolderItem = objFolder.Self
objPath = objFolderItem.Path
End Sub

Sub ShowFolderList(folderspec)
Dim fs, f, f1, fc, s, x
x = 0
s = objPath & ":" & vbCrLf & vbCrLf
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set fc = f.Files
For Each f1 in fc
If (x < 10) Then
s = s & f1.name
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 & "diese und alle anderen Dateien umbenennen in:"
strNewName = InputBox (s,WScript.Scriptname & " - Neuer Dateiname","NeuerName")
If (IsEmpty(strNewName) = True) Then
WScript.Quit
End If
End Sub


Sub ShowFileList(folderspec)
Dim fs, f, f1, fc, s
s = 1
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set fc = f.Files
For Each f1 in fc
RenameFile f1, s
s = s+1
Next
End Sub


Function RenameFile(fileName, x)
Dim objFSO, strDest, strName, strExt, arrLen, intLen, strMessage
arrLen = Array("000","00","0")
strName = "\" & strNewName
strExt = Lcase(right(fileName,4))
intLen = Len(x)
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
Select Case intLen
Case 1 strName = strName & arrLen(0) & x
Case 2 strName = strName & arrLen(1) & x
Case 3 strName = strName & arrLen(2) & x
Case Else strName = strName & x
End Select
Set objFSO = CreateObject("Scripting.FileSystemObject")
strDest = objPath & strName & strExt
objFSO.CopyFile fileName , strDest , OverWriteFiles
objFSO.DeleteFile fileName
End Function






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