ShortenFolderNames

This code takes folders dragged and dropped win the format '99.99.99.(ADMIN|ADMN|PMOD)' and creates a shortcut by that name, renames the folder to '99.99.99-ADMN' shortening the file path.

Option Explicit

Const ThisScriptVersion = "2016-01-13.16.31"

''drag and drop or send to

Dim WSH 'As New WshShell

''take folder name(s)

''for each fn in names

    ''look for numeric portion

    ''split after end of numeric portion

    ''$fp= filepath to folder

    ''$1= folder number id

    ''$2= descriptive for human name

    ''Rename folder $1

    ''Create shortcut in $fp

    ''Point to $1

    ''Name of shortcut "shortcut - " Optional + $1 + $2

''end for

''''Debug in excel

''Dim wscript As New objWSCRIPT_Emulator

Dim FSO ''As New FileSystemObject

main

'''''''''''''''''''

Sub test()

    Set FSO = CreateObject("Scripting.FileSystemObject")

    CreateShortcut "P:\60439114_Repair_Cadet_Chapel\7.0 - _CAD_GIS"

End Sub

Sub main()

If MsgBox("This will take folders dragged/dropped to script named '99.99.99-longfilename'" & vbCr _

        & "Rename it '99.99.99'" & vbCr _

        & "and create a shortcut" & vbCr _

        & "'99.99.99.longnamehere' that points back the file." & vbCr _

        & vbCr _

        & "Continue?", vbYesNo + vbExclamation, "Warning- this will rename folders and break filepaths.") <> vbYes Then

    MsgBox "Exiting. Nothing changed."

    wscript.quit

End If

   ''BEGIN BODY

   ''cHECK ARGS- IF USER DOUBLE CLICKED OR NO ARGS RETURN INSTRUCTIONS

   Set FSO = CreateObject("Scripting.FileSystemObject")

  

   If wscript.Arguments.count = 0 Then

      MsgBox "This Script version:" & ThisScriptVersion & vbCr & "Drag and drop a file or folder, or SendTo " & wscript.ScriptFullName & " to strip non-numeric folder titles and create 'human' shortcuts to erenamed folder.", vbOK, "Error"

      wscript.quit

   End If

  

   If wscript.Arguments.count > 0 Then

      Dim ArgItem  ''Arg Item in wscript

      Dim DirCt    ''Count Directories in drag and drop

      Dim FileCt   ''Count Files in drag and drop

      Dim Folders() ''list of folders

      Dim x

     

      For Each ArgItem In wscript.Arguments

         ''If FileExists(ArgItem) Then FileCt = FileCt + 1

         If FSO.FolderExists(ArgItem) Then

            DirCt = DirCt + 1

            ReDim Preserve Folders(DirCt)

            Folders(DirCt) = ArgItem

        End If

      Next

     

      If DirCt + FileCt <> wscript.Arguments.count Then

         MsgBox "File Or Directory Does Not Exist", vbOK, "Source File or Folder error"

         EXIT_CLEANUP

      End If

   End If

  

    Dim i, strs

    For i = 1 To DirCt

        strs = strs & vbCr & Folders(i)

        CreateShortcut Folders(i)

    Next ''i

    MsgBox (strs)

End Sub

Sub EXIT_CLEANUP()

End Sub

Sub CreateShortcut(fpFolder) ''As String)

''msgbox fpFolder

    Dim LNK ''''As link

    Dim PFolder  ''As Folder

    Dim oUrlLink

    Dim fn1 ''As String

    Dim fn2  ''As String

   

    Dim strLnkFP

   

    Dim x

        Set PFolder = FSO.GetFolder(fpFolder)

        x = RegexpSplit(PFolder.Name)

       

        ''Check for enough returns to create shortcut

        Dim xi

        xi = -1

        xi = UBound(x)

        If xi < 1 Then Exit Sub ''couldn't latch onto a common name format

       

        ''If no change in pfolder name no need to shortcut

        If FSO.FolderExists(PFolder.ParentFolder.Path & "\" & x(0)) Then Exit Sub

        

        Set WSH = wscript.CreateObject("WScript.Shell")

        ''strDesktop = WSH.SpecialFolders("Desktop")

        strLnkFP = PFolder.ParentFolder & "\" & PFolder.Name & ".lnk"

        If FSO.FileExists(strLnkFP) Then FSO.DeleteFile (strLnkFP)

        MsgBox x(0)

        Set LNK = WSH.CreateShortcut(strLnkFP) ''original name for link

       

       

        ''rename folder

        PFolder.Name = x(0)

        LNK.TargetPath = PFolder.Path ''wscript.ScriptFullName

        LNK.WindowStyle = 1

        ''LNK.Hotkey = "CTRL+SHIFT+F"

        ''LNK.IconLocation = "notepad.exe, 0"

        LNK.Description = x(0) & x(1)

        LNK.WorkingDirectory = PFolder.Path

        LNK.Save

        ''Set oUrlLink = WSH.CreateShortcut(fpFolder & "\Microsoft Web Site.url")

        ''oUrlLink.TargetPath = "http://www.microsoft.com"

        ''oUrlLink.Save

End Sub

Sub RegexpSplitTest()

    Debug.Print RegexpSplit("1.0_Admin")(0)

End Sub

Function RegexpSplit(strFN) ''As String) ''returns array of 2 items matching '###.###...' and the remainder

  Dim rgq ''As String

  ''rgq = "((?:\d+\.{0,1}){1,})(.*)"

   rgq = "((?:\d+\.{0,1}){1,}[^a-z,0-9]{0,}(?:ADMIN|ADMN|PMOD|PMGT){0,1})(.*)"

  Dim RegEx ''As New RegExp

  Set RegEx = CreateObject("vbscript.regexp")

 

  RegEx.Pattern = rgq

  RegEx.IgnoreCase = True

  Dim m ''As MatchCollection

  Set m = RegEx.Execute(strFN)

 

  If m.Item(0).SubMatches.count > 0 Then ''values weere found to match 2 subexpressions

    ReDim x(1)

    x(0) = UCase(m.Item(0).SubMatches.Item(0))

    x(1) = m.Item(0).SubMatches.Item(1)

  Else

    ReDim x(0)

    x(0) = strFN    ''error return 1 value only

  End If

   

    RegexpSplit = x ''return value

   

  Set RegEx = Nothing

 

End Function