'@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