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





Comments

Popular posts from this blog

Revit area plans adding new types and references (Gross and rentable)

Organization and management of data in Revit across omniclass, Masterformat, Uniclass, and Uniformat