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


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."
End If

   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"
   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
      If DirCt + FileCt <> wscript.Arguments.count Then
         MsgBox "File Or Directory Does Not Exist", vbOK, "Source File or Folder error"
      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

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
        ''Set oUrlLink = WSH.CreateShortcut(fpFolder & "\Microsoft Web Site.url")
        ''oUrlLink.TargetPath = ""
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)
    ReDim x(0)
    x(0) = strFN    ''error return 1 value only
  End If
    RegexpSplit = x ''return value
  Set RegEx = Nothing
End Function


Popular posts from this blog

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

Revit Floor patterns and materials