Cacher is the code snippet organizer for pro developers

'@Folder("Project")

'***********************************************************************************************************************
'************************************ PUBLIC PART, USER INTERFACE ******************************************************
'***********************************************************************************************************************

' Please run Print_Tprepared_ProjFolders_OT for info or Delete_TPrepared_ProjectFolders_OT for action!

' These routines will build a list (Print...) or delete project folders (Delete...) older than a limit date, from
' "T:\Prepared originals folder". It will only select properly named GSC project folders, highly GSC specific then.
'
' Both routines will ask for a limit date, selecting only folders whose dates of creation and modification are
' older than the one supplied.
'
' The Print... routine will build the list of folders and create anew document with info
' The Delete... routine will report on the folders it was unable to delete for some reason and numbering info

Private BaseDocName As String                       ' BackupQ
Private DocType(1, 18) As String                    ' Is_GSC_Doc
Private DocSuff(1, 5) As String                     ' Is_GSC_Doc
Private DocYear() As String                         ' Is_GSC_Doc
Private EUDocLang(1, 24) As String                  ' Is_GSC_Doc


Public Sub Print_Tprepared_ProjFolders_OT()

Dim OlderThanDate As String

OlderThanDate = InputBox("Please input «older than» date. («20/07/2017»)" & vbCr & vbCr & _
    "Selected project folders will have modification date and creation date older than this one", "Input date barrier")

If Not IsDate(OlderThanDate) Then
    MsgBox "Please type a valid date, in format «dd/mm/yyyy»!"
    Exit Sub
End If

Dim res As Variant

res = get_TPrepared_ProjFolders_OT(OlderThanDate)

Dim tmpList As String


If IsArray(res) Then
    Debug.Print "Found & " & UBound(res) + 1 & " old TPrepared project folders"
    For i = 0 To UBound(res)
        tmpList = IIf(tmpList = "", res(i) & vbCr, tmpList & res(i) & vbCr)
    Next i
    Documents.Add.Content.InsertAfter ("Found " & UBound(res) + 1 & " TPrepared project folders" & vbCr & "OLDER THAN: " & OlderThanDate & vbCr & vbCr & tmpList)
Else
    Debug.Print "Found NO folders on TPrepared older than " & OlderThanDate
End If



End Sub


Public Sub Delete_TPrepared_ProjectFolders_OT()

Dim RestrictToNumber As Integer

Dim OlderThanDate As String

OlderThanDate = InputBox("Please input «older than» date. («20/07/2017»)" & vbCr & vbCr & _
    "Selected project folders will have modification date and creation date older than this one", "Input date barrier")

If Not IsDate(OlderThanDate) Then
    MsgBox "Please type a valid date, in format «dd/mm/yyyy»!"
    Exit Sub
End If


If MsgBox("Would you like to limit number of affected folders to a subset?", vbYesNo + vbQuestion, "That many?") = vbYes Then
    
    RestrictToNumber = InputBox("Please input number of folder to delete", "How many?")
    
    If Not IsNumeric(RestrictToNumber) Then
        MsgBox "Please supply an integer number of folders!"
        Exit Sub
    End If
    
End If


Dim res As Variant

res = get_TPrepared_ProjFolders_OT(OlderThanDate)   ' array of found project folders


Dim tmpList As String


If IsArray(res) Then
    
    Debug.Print "Found & " & UBound(res) + 1 & " old TPrepared project folders:"

    Dim delRes As Variant    ' a list of folders NOT deleted or empty string for success!
    
    If Not IsMissing(RestrictToNumber) Then
        delRes = DeleteAllFolders(res, RestrictToNumber)
    Else
        delRes = DeleteAllFolders(res)
    End If
    
Else
    Debug.Print "Found NO folders on TPrepared older than " & OlderThanDate
End If


' did we get an array of not-deleted folders?
If IsArray(delRes) Then
    If UBound(delRes) > 0 Then
    
        If Not IsMissing(RestrictToNumber) Then
            MsgBox "Routine was unable to delete " & UBound(delRes) + 1 & " folders from TPrepared (from" & RestrictToNumber & ":" & vbCr & vbCr & delRes
        Else
            MsgBox "Routine was unable to delete " & UBound(delRes) + 1 & " folders from TPrepared (from" & UBound(res) & ":" & vbCr & vbCr & delRes
        End If
    
    Else    ' no returned unable-to-delete folders!
        
        If delRes(0) <> "" Then
            MsgBox "Routine was unable to delete " & UBound(delRes) + 1 & " folders from TPrepared (from" & UBound(res) & ":" & vbCr & vbCr & delRes
        Else     'no errors returned
            If Not IsMissing(RestrictToNumber) Then
                MsgBox "Successfully deleted " & RestrictToNumber & " old project folders!", vbOKOnly + vbInformation, "Success!"
            Else
                MsgBox "Successfully deleted " & UBound(res) & " old project folders!", vbOKOnly + vbInformation, "Success!"
            End If
        End If
        
    End If
Else    ' no errors returned
    MsgBox "Found NO folders on TPrepared older than " & OlderThanDate
End If

End Sub


'****************************************************************************************************************
'********************** Private part, internal functions, usually not for user usage ****************************
'****************************************************************************************************************

Private Function get_GSC_Folders(RootFolder As String) As Variant


Dim fso As New Scripting.FileSystemObject

If Not fso.FolderExists(RootFolder) Then
    
    MsgBox "Provided root folder does not exist, Quitting..."
    get_GSC_Folders = Empty
    Exit Function
    
End If


Dim rFdr As Scripting.Folder

Set rFdr = fso.GetFolder(RootFolder)

If rFdr.SubFolders.Count = 0 Then
    MsgBox "Found no subfolder to provided root folder (" & RootFolder & "), Quitting..."
    get_GSC_Folders = Empty
    Exit Function
End If


Dim tmpResults As Variant

ReDim tmpResults(0)

Dim n As Integer
Let n = 0

Dim k As Integer

Let k = -1  ' first found result will see this increase to 0


Dim tmpFdr As Scripting.Folder

For Each tmpFdr In rFdr.SubFolders
    
    If Is_GSC_Doc(tmpFdr.Name) Then
        
        Let k = k + 1
        
        If k > 100 Then Exit For
        
        ReDim Preserve tmpResults(k)
        
        tmpResults(k) = tmpFdr.Path
    
    Else    'Count and collect badly named folders
        
        Let n = n + 1
        
        If n = 1 Then
            Debug.Print "Found following badly named subfolders: "
        Else
            Debug.Print tmpFdr.Name
        End If
        
        
    End If
    
Next tmpFdr


Debug.Print "Captured " & k & " GSC project folders (&" & n & " badly named) - " & k + n & " in total"


get_GSC_Folders = tmpResults

Set fso = Nothing
Set rFdr = Nothing

End Function



Private Function get_TPrepared_ProjFolders_OT(OlderThanDate As String) As Variant
' Function returns an array of folder paths of whom both the date of creation and
' date of last modification is older than specified date in string format
' Expected string format: "01/11/2015")


Dim fso As New Scripting.FileSystemObject

Dim baseFolder As Scripting.Folder

Set baseFolder = fso.GetFolder("T:\Prepared originals")


Dim tmpResult

Dim fdr As Scripting.Folder

Dim fdrDateCreated As Date
Dim fdrDateModified As Date

Dim k As Integer
Let k = -1

For Each fdr In baseFolder.SubFolders
    
    If Is_GSC_Doc(fdr.Name) Then
        
        fdrDateCreated = get_FdrDateCreated_Property(fdr.Path)
        fdrDateModified = get_FdrDateModified_Property(fdr.Path)
        
        If DateDiff("d", fdrDateCreated, CDate(OlderThanDate)) > 0 And _
            DateDiff("d", fdrDateModified, CDate(OlderThanDate)) > 0 Then
            
            Let k = k + 1   ' 0 on first hit
            
            ' DEBUGGING
            'If k > 100 Then Exit For
            
            If Not IsArray(tmpResult) Then
                ReDim tmpResult(k)
            Else
                ReDim Preserve tmpResult(k)
            End If
            
            tmpResult(k) = fdr.Path
            
        End If
        
    End If
    
Next fdr

get_TPrepared_ProjFolders_OT = tmpResult

End Function



Private Function get_FdrDateModified_Property(FolderPath As String, Optional ReturnString) As Variant

Dim fso As New Scripting.FileSystemObject
Dim f As Scripting.Folder


If Dir(FolderPath, vbDirectory) <> "" Then
    
        
    Set f = fso.GetFolder(FolderPath)
    
    If Not IsMissing(ReturnString) Then
        get_FdrDateModified_Property = CStr(Split(f.DateCreated, " ")(0))
    Else
        get_FdrDateModified_Property = CDate(Split(f.DateCreated, " ")(0))
    End If
    
   
Else
    get_FdrDateModified_Property = ""
End If

End Function


Private Function get_FdrDateCreated_Property(FolderPath As String) As String

Dim fso As New Scripting.FileSystemObject
Dim f As Scripting.Folder


If Dir(FolderPath, vbDirectory) <> "" Then
    
        
    Set f = fso.GetFolder(FolderPath)
    get_FdrDateCreated_Property = Split(f.DateCreated, " ")(0)
    
   
Else
    get_FdrDateCreated_Property = ""
End If

End Function



Private Function DeleteAllFolders(InputFoldersArray, Optional RestrictToNumber) As Variant
' Function could return list of folders it did not succeed in deleting or empty string for succes?

Dim fo As New Scripting.FileSystemObject

Dim fd As Scripting.Folder

Dim tmpRes() As String
ReDim tmpRes(0)


If IsArray(InputFoldersArray) Then

    For i = 0 To UBound(InputFoldersArray)
        
        If Not IsMissing(RestrictToNumber) Then
            If i >= RestrictToNumber Then Exit For
        End If
        
        If Dir(InputFoldersArray(i), vbDirectory) <> "" Then
            
            Set fd = fo.GetFolder(InputFoldersArray(i))
            
            On Error GoTo ErrDeletingF
            

            
            Debug.Print "Deleting " & fd.Path
            
            fd.Delete Force:=True
            
            DoEvents
            
            Call GSCRo_Lib.PauseForSeconds(0.7) ' NECESSARY?
            
        End If
        
SkipNextFolder:
    Next i

End If

DeleteAllFolders = tmpRes


Exit Function

'**************************************************

ErrDeletingF:
    If Err.Number <> 0 Then
        Debug.Print "Error " & Err.Number & ": " & Err.Description & " for del fdr: " & InputFoldersArray(i)
        
        If tmpRes(0) <> "" Then ReDim Preserve tmpRes(UBound(tmpRes) + 1)
        tmpRes(UBound(tmpRes)) = InputFoldersArray(i)
        'tmpRes = IIf(tmpRes = "", InputFoldersArray(i), tmpRes & vbCr & InputFoldersArray(i))
        Err.Clear
        GoTo SkipNextFolder
    End If


End Function


Function Is_GSC_Doc(FileName As String, Optional SilentMode) As Boolean
' version 0.6
' independent
' depends on VerificaCN
' 0.5 - Added XM, XN, XT
' 0.6 - Minding only first 2 groups of chars separated by dot.

Dim MsgS As String
Dim PointPos As Byte
Dim LinePos As Byte
Dim ff As New Scripting.FileSystemObject

' Is filename extensioned or not ? (".doc" extension)
If Right$(FileName, 5) = ".docx" Or Right$(FileName, 4) = ".doc" Then
    ' This way we ONLY look at
    If UBound(Split(FileName, ".")) = 2 Then
        BaseDocName = ff.GetBaseName(FileName)
    Else
        BaseDocName = Split(FileName, ".")(0) & "." & Split(FileName, ".")(1)
    End If
Else
    BaseDocName = FileName
End If

PointPos = InStr(1, BaseDocName, ".")
    
Select Case PointPos
    Case 0
        MsgS = "Not Council document, or not properly named! Cherish the point!"

Ooops:  If IsMissing(SilentMode) Then
            StatusBar = MsgS
        End If
        
        Is_GSC_Doc = False
        Exit Function
        
    Case Is = 8
        LinePos = InStr(1, BaseDocName, "-", vbTextCompare)
            If LinePos <> 0 And LinePos <= PointPos Then MsgS = _
            "Not Council document, or not properly named! Where's your line at?": GoTo Ooops
    Case Is > 9
        If (PointPos - 9) Mod 4 <> 0 Then MsgS = _
        "Not Council document, or not properly named! Where's your point at?": GoTo Ooops
        LinePos = InStr(1, BaseDocName, "-", vbTextCompare)
        If LinePos <> 8 Then MsgS = _
        "Not Council document, or not properly named! Cherish your lines!": GoTo Ooops
    Case Else
        MsgS = "Not Council document, or not properly named! Where's your point at?": GoTo Ooops
End Select

Set ff = Nothing

DocType(0, 0) = "st": DocType(0, 7) = "cp"
DocType(0, 1) = "sn": DocType(0, 8) = "ad"
DocType(0, 2) = "cm": DocType(0, 9) = "ac"
DocType(0, 3) = "ds": DocType(0, 10) = "nc"
DocType(0, 4) = "lt": DocType(0, 11) = "np"
DocType(0, 5) = "bu": DocType(0, 12) = "da"
DocType(0, 6) = "pe": DocType(0, 13) = "rs"
DocType(0, 14) = "cg": DocType(0, 15) = "fa"
DocType(0, 16) = "xm": DocType(0, 17) = "xn"
DocType(0, 18) = "xt"


DocType(1, 0) = "1"
DocType(1, 1) = "2"

DocSuff(0, 0) = "re": DocSuff(0, 3) = "ex"
DocSuff(0, 1) = "co": DocSuff(0, 4) = "am"
DocSuff(0, 2) = "ad": DocSuff(0, 5) = "dc"

DocSuff(1, 0) = 8
DocSuff(1, 1) = PointPos - 8

ReDim DocYear(1, (Right$(DatePart("yyyy", Date), 2)) - 1) 'Ultimele doua cifre ale anului curent
j = -1

For i = Right$(DatePart("yyyy", Date), 2) To 1 Step -1
    j = j + 1
    DocYear(0, j) = Format(i, "00")
Next i

DocYear(1, 0) = PointPos + 3
DocYear(1, 1) = "2"

EUDocLang(0, 0) = "en": EUDocLang(0, 12) = "cs"
EUDocLang(0, 1) = "fr": EUDocLang(0, 13) = "et"
EUDocLang(0, 2) = "ro": EUDocLang(0, 14) = "lv"
EUDocLang(0, 3) = "de": EUDocLang(0, 15) = "lt"
EUDocLang(0, 4) = "nl": EUDocLang(0, 16) = "hu"
EUDocLang(0, 5) = "it": EUDocLang(0, 17) = "mt"
EUDocLang(0, 6) = "es": EUDocLang(0, 18) = "pl"
EUDocLang(0, 7) = "da": EUDocLang(0, 19) = "sk"
EUDocLang(0, 8) = "el": EUDocLang(0, 20) = "sl"
EUDocLang(0, 9) = "pt": EUDocLang(0, 21) = "bg"
EUDocLang(0, 10) = "fi": EUDocLang(0, 22) = "xx"
EUDocLang(0, 11) = "sv": EUDocLang(0, 23) = "hr"
EUDocLang(0, 24) = "ga"     ' Rarer gaelic - irish

EUDocLang(1, 0) = PointPos + 1
EUDocLang(1, 1) = 2


For i = 1 To 5
    If VerificaCN(i, BaseDocName) = False Then
        MsgS = "Not Council Document, Sorry!"
        GoTo Ooops
    End If
Next i

Is_GSC_Doc = True

End Function

Function VerificaCN(VerifN, VString As String) As Boolean   ' Verifica Council Name
' version 1.0
' independent
' Added "DCL" suffix to represent declasiffications

Dim CeVerificam
Dim EValid As Boolean, ENumeric As Boolean

Select Case VerifN
Case Is = 1
        CeVerificam = DocType()
VLoop:  For j = 0 To UBound(CeVerificam, 2)
            If StrComp(Mid$(BaseDocName, CeVerificam(1, 0), CeVerificam(1, 1)), _
            CeVerificam(0, j), vbTextCompare) = 0 Then
                VerificaCN = True
                Exit For
            End If
        Next j

Case Is = 2
    If IsNumeric(Mid$(BaseDocName, 3, 5)) = True Then VerificaCN = True
        
Case Is = 3
    If InStr(1, BaseDocName, "-", vbTextCompare) = 0 Then
        VerificaCN = True
    ElseIf InStr(1, BaseDocName, "-", vbTextCompare) = 8 Then
        For n = 1 To (DocSuff(1, 1) - 1) / 4
            EValid = False
            For j = 0 To UBound(DocSuff, 2)
                If StrComp(Mid$(BaseDocName, (8 + (4 * n - 3)), 2), DocSuff(0, j), vbTextCompare) = 0 Then
                    EValid = True
                    Exit For
                End If
            Next j
            If EValid = False Then Exit For
        Next n
        For n = 1 To (DocSuff(1, 1) - 1) / 4
        ENumeric = False
            If IsNumeric(Mid$(BaseDocName, (8 + (4 * n - 1)), 2)) = True Then ENumeric = True
            If ENumeric = False Then Exit For
        Next n
        
        If EValid = True And ENumeric = True Then VerificaCN = True
    End If
Case Is = 4
    CeVerificam = EUDocLang()
    GoTo VLoop
Case Is = 5
    CeVerificam = DocYear()
    GoTo VLoop
End Select

End Function