Logo Foltyn Presentation
Table of Contents Previous Page Next Page
Content-Symbol-Img
Ein Programm in der Programmiersprache A program in the programming language
vbScript
zur Kürzung von Verzeichnisnamen to shorten foldernames

     Wenn sich ein Verzeichnisbaum nicht löschen läßt, weil Dateinamen zusammen mit den Pfaden mehr als 256 Zeichen lang sind und der Baum ist zur Löschung bestimmt, dann kann man mit Hilfe des folgenden Programms die Verzeichnisnamen kürzen.
     Das Programm läuft auf Windows XP und 7 und bietet ein Verzeichnisauswahl-Fenster zur Auswahl des Basis-Verzeichnisses. Es wird gezeigt, wie man in Prozeduren Arrays übergeben kann, indem bei jedem Verzeichnis die Sub-Verzeichnis-Liste an die Haupt-Verzeichnis-Liste angehängt wird, während die Listen-Positionen abgearbeitet werden.

     If a foldertree cannot be erased, because filenames together with the pathes are longer as 256 characters and the tree is determined to be erased, than one can shorten the foldernames by means of the following program.
     The program runs on Windows XP and 7 and offers a folder-select-window for choice of the basefolder. It is shown, how in procedures arrays can be handed over, whilst by every folder the subfolder-list is attached to the mainfolder-list, while the list-items are worked off.

Das Programm ist getestet vor der Publikation, aber es kann keine Garantie gegeben werden, dass es fehlerfrei ist
The program ist tested before publication, but there can be given no guarantee, that it is free of errors
16. Mai 2012 May 16th 2012

' Shorten too long pathes

Option Explicit

' Constants, Variables + Objects

Dim BaseFolder, SubFolderList, NewFolderNr, AllFoldersList, Pointer

' Program

RenameAllFolders

' End of Program

' Procedures

Sub RenameAllFolders
    Dim fso, j
    Set fso = CreateObject("Scripting.FileSystemObject")

    BaseFolder = BrowseFolder( "MY COMPUTER", True )

    NewFolderNr = 0
    If BaseFolder = "" Then
        MsgBox "No Basefolder chosen"
    ElseIf (fso.FolderExists(BaseFolder)) Then
        ReDim AllFoldersList(0): AllFoldersList(0) = BaseFolder
        Pointer = -1
        Do
            Pointer = Pointer + 1: NewFolderNr    = 0
            SubFolderList = RenameSubFolders(AllFoldersList(Pointer))
            AddListToAllFoldersList SubFolderList
        Loop Until Pointer = UBound(AllFoldersList)

        MsgBox "Procedure done"
    Else
        MsgBox "Basefolder not exists"
    End If
    Set fso = Nothing
End Sub

Function RenameSubFolders(folderspec)
    Dim fso, f, f1, fc, AnyArray, i
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.GetFolder(folderspec)
    Set fc = f.SubFolders
    i = -1
    For Each f1 In fc
        i = i + 1: NewFolderNr = NewFolderNr + 1
        f1.Name = CStr(NewFolderNr)
    Next
    ReDim AnyArray(i)
    i = -1
    For Each f1 In fc
        i = i + 1: AnyArray(i) = folderspec & "\" & f1.Name
    Next
    RenameSubFolders = AnyArray
    Erase AnyArray
    Set fso = Nothing
End Function

Sub AddListToAllFoldersList(AnyList)
    Dim i, NrOfItems
    NrOfItems = UBound(AllFoldersList)
    For i = 0 To UBound(AnyList)
        NrOfItems = NrOfItems + 1
        ReDim Preserve AllFoldersList(NrOfItems)
        AllFoldersList(NrOfItems) = AnyList(i)
    Next
    ReDim Preserve AllFoldersList(NrOfItems)
End Sub

Function BrowseFolder( myStartLocation, blnSimpleDialog )
    ' This function generates a Browse Folder dialog
    ' and returns the selected folder as a string.
    Const MY_COMPUTER = &H11&
    Const WINDOW_HANDLE = 0 ' Must ALWAYS be 0

    Dim numOptions, objFolder, objFolderItem
    Dim objPath, objShell, strPath, strPrompt

    ' Set the options for the dialog window
    strPrompt = "Select a folder:"
    If blnSimpleDialog = True Then
        numOptions = 0 ' Simple dialog
    Else
        numOptions = &H10& ' Additional text field to type folder path
    End If

    ' Create a Windows Shell object
    Set objShell = CreateObject( "Shell.Application" )

    ' If specified, convert "My Computer" to a valid
    ' path for the Windows Shell's BrowseFolder method
    If UCase( myStartLocation ) = "MY COMPUTER" Then
        Set objFolder = objShell.Namespace( MY_COMPUTER )
        Set objFolderItem = objFolder.Self
        strPath = objFolderItem.Path
    Else
        strPath = myStartLocation
    End If

    Set objFolder = objShell.BrowseForFolder( WINDOW_HANDLE, strPrompt, _
    numOptions, strPath )

    ' Quit if no folder was selected
    If objFolder Is Nothing Then
        BrowseFolder = ""
        Exit Function
    End If

    ' Retrieve the path of the selected folder
    Set objFolderItem = objFolder.Self
    objPath = objFolderItem.Path

    ' Return the path of the selected folder
    BrowseFolder = objPath
End Function

' End of Procedures