Folder Maker and shortcut creater AND REcurse Checker

MODULE FOLDER MAKER

Option Explicit
Private fso As New FileSystemObject

Dim RecurseCheck As New recurselimit

Dim WSH As WshShell

Public Sub CreateFolderStructure()
    Set WSH = CreateObject("WScript.Shell")    ''WshShell
    ''Set lnk = CreateObject("WScript.Shell")    ''As WshShortcut

    RecurseCreateFolders "00-ROOT"   ''entry point iis to pass name of root sheet to recursive process
    
    ''Set lnk = Nothing
    Set WSH = Nothing
    MsgBox "DONE"
    
End Sub

Private Sub RecurseCreateFolders(ByVal strWSSub As String, Optional ByVal strFPpfix As String) '', Optional FN As String, Optional XCUT As String)
Dim lastrow As Integer
Dim I
Dim strFP As String
    If strWSSub <> "00-ROOT" And RecurseCheck.LimitReached(strWSSub) Then Exit Sub
    
    If strFPpfix > "" Then
        If Right(strFPpfix, 1) <> "\" Then
            strFP = strFPpfix & "\"
        End If
    End If
    
    If Not WorksheetExists(strWSSub) Then Exit Sub

    ''get number of rows on sheet
    lastrow = GETLastCellRange(ActiveWorkbook.Worksheets(strWSSub).Range("$a:$A")).Row
    For I = 2 To lastrow
        strFP = strFPpfix & ActiveWorkbook.Worksheets(strWSSub).Cells(I, 1).Value & "\"
        
        CreateFolder strFP
        CreateShortcut strFPpfix, strFP, strclean(ActiveWorkbook.Worksheets(strWSSub).Cells(I, 2).Value)
        If ActiveWorkbook.Worksheets(strWSSub).Cells(I, 3).Value > "" Then ''subfolder tab should exist
            RecurseCreateFolders ActiveWorkbook.Worksheets(strWSSub).Cells(I, 3).Value, strFP
        End If
    Next I
    
    strFPpfix = ""
End Sub

Private Function WorksheetExists(ByVal WorksheetName As String) As Boolean
    On Error Resume Next
    WorksheetExists = (Sheets(WorksheetName).name <> "")
    On Error GoTo 0
End Function

Private Sub testCreateFolder()
    CreateFolder "C:\temp\foo\bar\deep"
End Sub
Private Sub CreateFolder(FP As String)
Dim x, I, fpp
    x = Split(FP, "\")
    fpp = x(0)
    For I = 1 To UBound(x)
        If x(I) > "" Then
            fpp = fpp & "\" & x(I)
            If Not fso.FolderExists(fpp) Then fso.CreateFolder (fpp)
        End If
    Next I
End Sub

'''''''''''''''''-------------------------------------------------------------------------------------------------------
Private Sub testLink()
    Call CreateShortcut("C:\Users\RON_ALLEN\Desktop", "C:\Users\RON_ALLEN\Desktop\FILE-STRUCTURES", "TEST XMIND FILE LINK")
End Sub
'''''''''''''''''-------------------------------------------------------------------------------------------------------
Private Sub CreateShortcut(ByVal PlacementFilePath As String, ByVal TargetFilePath As String, ByVal ShortcutName As String)
''PlacementFilePath     ="C:\Users\RON_ALLEN\Desktop"
''TargetFilePath        = "C:\Users\RON_ALLEN\Desktop\FILE-STRUCTURES"
''ShortcutName          ="TEST XMIND FILE LINK"

''Dim WSH As WshShell
Dim lnk As WshShortcut
Dim strXName As String
Dim oFolder As Folder

ShortcutName = strclean(ShortcutName)

Dim StartIn As String
    Set lnk = Nothing
    On Error GoTo Proc_Err

    Set oFolder = fso.GetFolder(TargetFilePath)

    StartIn = oFolder.Path
    
    'Do While Right(StartIn, 1) <> "\" And Len(StartIn) > 3
    '    StartIn = Left(StartIn, Len(StartIn) - 1)
    'Loop
    'StartIn = Left(StartIn, Len(StartIn))
        
    If PlacementFilePath = "" Then PlacementFilePath = oFolder.ParentFolder.Path
    
    'Do While Right(PlacementFilePath, 1) <> "\" And Len(PlacementFilePath) > 3
    '    PlacementFilePath = Left(PlacementFilePath, Len(PlacementFilePath) - 1)
    'Loop
   
    'Set WSH = CreateObject("WScript.Shell")
    strXName = Trim(Left(PlacementFilePath & "\" & ShortcutName, 128)) & ".lnk"
    Set lnk = WSH.CreateShortcut(strXName)
    
    lnk.TargetPath = TargetFilePath
    lnk.Arguments = StartIn
    ''comment:
    lnk.Description = ""
    lnk.Description = Trim(Left("Created with shortcut generator: " & ShortcutName, 200))
    'lnk.HotKey = ""
    'lnk.IconLocation = ""
    'lnk.WindowStyle = "1"
    lnk.WorkingDirectory = StartIn
    lnk.Save
    'Clean up
    
Proc_Exit:
    On Error GoTo 0
    Set lnk = Nothing
    ''Set WSH = Nothing
    Exit Sub
  
Proc_Err:
    MsgBox Err.Description, , _
        "ERROR " & Err.Number _
        & "   CreateShortcut "
    Stop
    Resume Proc_Exit
    Resume
    
End Sub
Private Function strclean(Str As String) As String
Dim I As Integer
Dim x As String
    For I = 1 To Len(Str)
        x = Mid(Str, I, 1)
        Select Case x
            Case "A" To "Z", "a" To "z", "_", " ", "0" To "9"     '''Characters to keep ''skip "-" to check for double "--"
                strclean = strclean & x
            Case Else
                If Right(strclean, 1) <> "-" Then strclean = strclean & "-" ''Characters else sub with a dash
        End Select
    Next I
End Function
Private Function GETLastCellWorksheet(objWrkSheet As Worksheet) As Range
    ''uses search to find last used cell in a sheet
    Set GETLastCellWorksheet = GETLastCellRange(objWrkSheet.Cells)
End Function

Private Function GETLastCellRange(objRange As Range) As Range
    ''uses search to find last used cell in a range
    Set GETLastCellRange = objRange.Find(What:="*", After:=objRange.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
    If GETLastCellRange Is Nothing Then ''empty workbook
        Set GETLastCellRange = objRange.Cells(1, 1)
    End If
End Function

''''''--------------------------------------------------------

''''SHEET MAKER MODULE

''''''--------------------------------------------------------

Option Explicit
Public strTabValidate As String
Public Const strTabRoot = "00-ROOT"            ''Special starting folder
Public Const strSubfolder = "Subfolders Tab"   ''Special column to look for in formatting
Public Const strFName = "Folder Name (Short-no spaces, use dashes)"
Public Const strFXCUT = "Folder Shortcut Name (Long name)"

Sub UpdateSheets()
    UpdateSheetFormatsAndValidation
End Sub
Sub UpdateSheetFormatsAndValidation(Optional ws As Worksheet)
    If ws Is Nothing Then
        For Each ws In ThisWorkbook.Worksheets
            Validate_SUBFOLDERS_TAB ws
            FormatSheet ws
        Next ws
    Else
        Validate_SUBFOLDERS_TAB ws
        FormatSheet ws
        For Each ws In ThisWorkbook.Worksheets
            Validate_SUBFOLDERS_TAB ws
        Next ws
    End If
End Sub

Sub Validate_SUBFOLDERS_TAB(ws As Worksheet)

    If ws Is Nothing Then Exit Sub
        
    Dim Target As Range
    Dim xws As Worksheet
    Dim strCurVal As String
    Dim I As Integer
    
    
    strTabValidate = ""
    
    For Each xws In ThisWorkbook.Worksheets
        If Not (xws.name Like strTabRoot Or xws.name Like ws.name) Then
            strTabValidate = xws.name & "," & strTabValidate
        End If
    Next xws
    
    If strTabValidate > "" Then
        strTabValidate = Left(strTabValidate, Len(strTabValidate) - 1)    'remove trailing comma
        ''bubble sort
        strTabValidate = BubbleSort(strTabValidate)
    End If


    ws.Unprotect
       
    For I = 1 To GETLastCellWorksheet(ws).Column
        If ws.Cells(1, I).Value = strSubfolder Then Exit For
    Next I
    
    ws.Cells.Validation.Delete
    
    Set Target = ws.Cells(1, I).EntireColumn
    With Target.Validation      ''<<<<<<<<<<
            
        If strTabValidate <> "" Then
            .Delete
            .add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:=strTabValidate
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = "TAB for subfolder structure"
            .ErrorTitle = "Please try again"
            .InputMessage = "Select a tab for a subfolder structure, or leave blank for empty/none"
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        Else
            strTabValidate = " "
            .add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:=strTabValidate
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = "Please add tabs"
            .ErrorTitle = "Please try again"
            .InputMessage = "Add Tabs to Select for a subfolder structure, or leave blank for empty/none"
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End If
    End With
    
End Sub


Private Function BubbleSort(sTmp) As String

  'cheapo bubble sort
  Dim aTmp, I, j, temp
  aTmp = Split(sTmp, ",")
  For I = UBound(aTmp) - 1 To 0 Step -1
    For j = 0 To I - 1
      If LCase(aTmp(j)) > LCase(aTmp(j + 1)) Then
        temp = aTmp(j + 1)
        aTmp(j + 1) = aTmp(j)
        aTmp(j) = temp
      End If
    Next
  Next
   
  BubbleSort = Join(aTmp, ",")
  
End Function

Sub x()
Dim ws As Worksheet
    Set ws = ActiveWorkbook.Worksheets("NCS")
    'FormatCells ws
    'Validate_SUBFOLDERS_TAB ws
    FormatSheet ws
    'FormatCells ws
End Sub

Sub FormatSheet(ws As Worksheet)
Dim I As Integer

    Dim objButton
    Dim objTarget As Range
    Dim objShp As Shape
    
    ws.Unprotect
    ws.Cells.Locked = False
    ws.Columns.Hidden = False
    
    ws.Cells(1, 1) = strFName
    ws.Cells(1, 2) = strFXCUT
    ws.Cells(1, 3) = strSubfolder
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    '''Format First Row''''''''''''''''''''''''''''''''''
    With ws.Rows("1:1").Font
        .name = "Calibri"
        .FontStyle = "Bold"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    '''Format First Row''''''''''''''''''''''''''''''''''
    With ws.Rows("1:1").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark2
        .TintAndShade = -0.499984740745262
        .PatternTintAndShade = 0
    End With
    
    
    With ws.Cells
        .ColumnWidth = 20
        .NumberFormat = "@"
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    For I = 1 To GETLastCellWorksheet(ws).Column
        If ws.Cells(1, I).Value = SheetMaker.strSubfolder Then Exit For
    Next I
    
    With ws.Cells(1, I).EntireColumn
        .ColumnWidth = 20
        .NumberFormat = "@"
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlTop
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
        For I = 1 To GETLastCellWorksheet(ws).Column
        If ws.Cells(1, I).Value = SheetMaker.strFXCUT Then Exit For
    Next I
    
    With ws.Cells(1, I).EntireColumn
        .ColumnWidth = 80
        .NumberFormat = "@"
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Application.PrintCommunication = False
    
    
    With ws.PageSetup
        .PrintTitleRows = "$1:$1"      '''<<
        .PrintTitleColumns = ""
    End With

    
    ws.PageSetup.PrintArea = "$a:$D"

    With ws.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.7)
        .RightMargin = Application.InchesToPoints(0.7)
        .TopMargin = Application.InchesToPoints(0.75)
        .BottomMargin = Application.InchesToPoints(0.75)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        ''.Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    
    ws.ResetAllPageBreaks
    
    On Error Resume Next
    Application.PrintCommunication = True
    On Error GoTo 0
    
    ''Add Click to star create Folders
    Set objTarget = ws.Range("$c$1")
    
    If ws.Shapes.count > 0 Then
       ws.Shapes(1).Delete
    End If

    Set objButton = ws.Buttons.add(objTarget.Left + objTarget.Width / 2, objTarget.Top, objTarget.Width / 2, objTarget.Height)
   
    With objButton
        .OnAction = "CreateFolderStructure"
        .Caption = "CreateFolders"
    End With
    
    'Stop
    ws.Activate
    'ws.Columns(Columns(GETLastCellWorksheet(ws).Column + 1), Cells(1, ws.Columns.Count)).EntireColumn.Hidden = True
    ws.Range(Cells(1, GETLastCellWorksheet(ws).Column + 1), Cells(1, ws.Columns.count)).EntireColumn.Hidden = True
    
End Sub

Private Function GETLastCellWorksheet(objWrkSheet As Worksheet) As Range
    ''uses search to find last used cell in a sheet
    Set GETLastCellWorksheet = GETLastCellRange(objWrkSheet.Cells)
End Function

Private Function GETLastCellRange(objRange As Range) As Range
    ''uses search to find last used cell in a range
    Set GETLastCellRange = objRange.Find(What:="*", After:=objRange.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
    If GETLastCellRange Is Nothing Then ''empty workbook
        Set GETLastCellRange = objRange.Cells(1, 1)
    End If
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''RECURSE LIMIT CLASS-------------------
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Option Explicit

Private Type xdat
    count As Integer     ' Declare a static array.
    tabname As String
End Type

Public tabname As String
Public TabCount As Integer
Dim Limit As Integer
Public StopTime As Date

Dim x()  As xdat

Public Function LimitReached(strTabReference As String) As Boolean
Dim I As Integer
Dim ub As Integer

StopTimeCheck

ub = -1
On Error Resume Next
ub = UBound(x)
On Error GoTo 0

LimitReached = False

For I = 0 To ub
    If x(I).tabname = strTabReference Then
        x(I).count = x(I).count + 1
        If x(I).count > Limit Then
            LimitReached = True
            'MsgBox "Limit reached"
            Stop
        End If
        Exit Function
    End If
Next I

''new unlisted tab
ReDim Preserve x(I) As xdat
    x(I).tabname = strTabReference
    x(I).count = 1
End Function

Private Sub Class_Initialize()
    Limit = 2
    StopTimeCheck
End Sub

Sub StopTimeCheck()
    If StopTime = 0 Or StopTime < Date + Time Then
        'Stop
        StopTime = Date + Time + 15 / 60 / 60 / 24
        Exit Sub
    End If

End Sub