'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