Wednesday, January 13, 2016

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





No comments:

Post a Comment