Option Explicit
Const version = "v2015-02-25-01.0"
''Script takes a csv text based output report from Deltek and uses it to create folder structure on P.
Const strFPt = "P:\" ''Target File PathDim FP
Const vbqt = """" ''define VBQt for quotation mark
''Lots of globals on this one:
Public strDataArr ''Readline of data from file
Public strDiscID ''discipline ID
Const RemapE = True ''Remap E will create the S/SZ folders if E is in the disciplines .
Const ForReading = 1, ForWriting = 2, ForAppending = 8 ''
''FILE MANIPULATION OBJECTS AND REFERENCES''''''''''''''''''
Dim fso ''As New FileSystemObject for creating folders
Dim objWSH ''As New WshShell for creating shortcuts
Dim strKeyID() ''for holding string of keys for comare
Dim KeySet ''Bool check if key was set
Dim strKeyUB ''Max ubound of key
Dim strDataUB ''ub of data array
Dim StrMsg ''for building up message
Dim intFolderCt ''Count of folders added
Dim intFolderRef ''Folders referenced
Dim MyFile ''MyFile for opening target file, Textline for holding one line at a time
Dim Textline ''MyFile for opening target file, Textline for holding one line at a time
Dim DirLevels ''Limiting dir levels if 0 ir unspecified limits to 2, if -1 create all subfolders for disciplines
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''END VARIABLES'''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Main ''Execute MAIN routine
'Dim wscript As New objWSCRIPT_Emulator ''FOR DEBUGGING IN EXCEL WITH WSCRIPT CLASSES
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''MAIN ROUTINE''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Main()
Dim FileName, I, temp ''input file name
DirLevels = -99 ''init as -99
Call Initilize(True) ''INITIALIZE VARIABLES (IN ANTICIPATION OF CONVERSAION OF THIS PARAMETER TO A CLASS)
''Sort WSCRIPT ARGS''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For I = 0 To wscript.Arguments.count - 1
If FileName = "" Then
FileName = ReturnMatch(wscript.Arguments(I), "([a-z]:\\(?:[-\w\s\.\d]+\\)*(?:[-\w\s\.\d]+)?)")
End If
If DirLevels = -99 Then
temp = ReturnMatch(wscript.Arguments(I), "\/limit:([-+]{0,1}\d+)") ''look for string from submatch
If temp > "" Then
DirLevels = CInt(temp)
End If
End If
Next 'i
If DirLevels = -99 And FileName > "" Then
temp = CInt(InputBox("Number of sub folders under client?" & vbCr & vbCr & _
"(P:\0.client\1.Region\(2.Product)\3.Disciplines\)" & vbCr & vbCr & _
"(-1 to create ALL 19+ Disciplines)", "Specify allowable depth of sub-folders", 2))
If temp < -1 Or temp > 3 Then
DirLevels = 3
Else
DirLevels = temp
End If
End If
If DirLevels = -99 Then DirLevels = 2
If FileName = "" Then
StrMsg = "Please create a 'project audit report' in deltek with Project#, client name, project name" & vbCr & _
"Save it as a CSV/TXT," & vbCr & _
"then drag and drop the report onto the script." & vbCr & _
"Or link the script to your SendTo folder " & vbCr & _
"and use sendto to send the report." & vbCr & vbCr & _
"-----SYNTAX-----------------------------------------------------------------" & vbCr & _
wscript.ScriptName & " [filepath] [/limit:nn]" & vbCr & _
"-----SWITCHES---------------------------------------------------------------" & vbCr & _
"Specify /LIMIT:[folder limit] for allowed subdirs below client(Default 2)" & vbCr & _
" -1 = create all disciplines" & vbCr & _
" 0 = Create client\ only " & vbCr & _
" 1 = Create client\region only " & vbCr & _
" 2 = Create client\region\product only " & vbCr & _
"[n...] = Limit to N number of sub-folders deep:" & vbCr & _
" P:\0.client\1.Region\2.Product\3.Disciplines (specified by report)"
Terminate (vbOKOnly & vbCritical)
Exit Sub
ElseIf Not fso.FileExists(FileName) Then
StrMsg = "ERROR, Cannot find file " & FileName
Terminate (vbOKOnly & vbCritical)
End If
On Error GoTo 0
' Open the file for input.
Set MyFile = fso.OpenTextFile(FileName, ForReading)
' Read from the file and display the results.
Do While MyFile.AtEndOfStream <> True '''while not eof
Textline = MyFile.ReadLine ''Get next line of data
Textline = Reformat(Textline) ''reformats csv to tab delimited and gets rid of quotes
If Textline > "" Then '' if not null
If ReturnMatch(Textline, "detail_*") > "" Then ''if matches detail
SetKeyInit (Textline)
Else
If KeySet Then
SetData (Textline) ''Set data array
CreateFolders strDataArr, fso
End If
End If
End If
Loop
Terminate (vbOKOnly)
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''Initialize variables and file manipulation objects'''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Initilize(noargs)
Set fso = CreateObject("Scripting.FileSystemObject") ''File System Object for creating folders
Set objWSH = CreateObject("WScript.Shell") ''Wscript shell for creating shortcuts
Dim q
q = Array( _
Array("00-00-C-", "00-00-C-Non-trades Client folder", "Non-trades Client folder(If not one of the other categories listed below)"), _
Array("01-00-G-", "01-00-G-General-Index", "G General All or any portion of subjects included in Level 2"), _
Array("05-00-C-", "05-00-C-Civil", "C Civil All or any portion of subjects included in Level 2"), _
Array("06-00-L-", "06-00-L-Landscape", "L Landscape All or any portion of subjects included in Level 2"), _
Array("07-00-S-", "07-00-S--Structural", "S Structural All or any portion of subjects included in Level 2"), _
Array("07-00-SZ", "07-00-SZ-Structural PM folder", "SZ Structural PROJECT MANAGERS FOLDER"), _
Array("08-00-A-", "08-00-A-Architectural", "A Architectural All or any portion of subjects included in Level 2"), _
Array("08-00-AZ", "08-00-AZ-Architectural PM FOLDER", "AZ Architectural PROJECT MANAGER FOLDER"), _
Array("09-00-I-", "09-00-I-Interiors", "I Interiors All or any portion of subjects included in Level 2"), _
Array("09-00-IZ", "09-00-IZ-Interiors PM FOLDER", "IZ Interiors PROJECT MANAGER FOLDER"), _
Array("10-00-Q-", "10-00-Q-Equipment", "Q Equipment All or any portion of subjects included in Level 2"), _
Array("11-00-F-", "11-00-F-Fire Protection", "F Fire Protection All or any portion of subjects included in Level 2"), _
Array("12-00-P-", "12-00-P-Plumbing", "P Plumbing All or any portion of subjects included in Level 2"), _
Array("14-00-M-", "14-00-M-Mechanical", "M Mechanical All or any portion of subjects included in Level 2"), _
Array("15-00-E-", "15-00-E-Electrical", "E Electrical All or any portion of subjects included in Level 2"), _
Array("16-00-T-", "16-00-T-Telecommunications", "T Telecommunications All or any portion of subjects included in Level 2"), _
Array("17-00-R-", "17-00-R-Resource Data", "R Resource Data furnished without warrant as to accuracy (e.g. typical or previous drawings used for reference)"), _
Array("18-00-X-", "18-00-X-Other Disciplines", "X Other Disciplines All or any portion of subjects included in Level 2"), _
Array("19-00-Z-", "19-00-Z-Contractor-Shop Drawings", "Z Contractor /Shop Drawings All or any portion of subjects included in Level 2"), _
Array("90-00---", "90-00---Inter-discipline meetings", "This category only used for inter-discipline meetings, i.e. team kickoff.") _
)
Dim ct
ct = UBound(q, 1)
ReDim strDiscID(ct + 1, 3)
Dim I
For I = 0 To ct - 1
strDiscID(I + 1, 1) = q(I + 1)(0)
strDiscID(I + 1, 2) = q(I + 1)(1)
strDiscID(I + 1, 3) = q(I + 1)(2)
Next ''I
''these are the variables to look for in exports in the reports
''data will be located in the same slot on one of the following lines
''These are keys to look for- if present they will be > -1 for the 'position of the ID'
q = Array( _
"detail_BillClientName", _
"detail_ClientName", _
"detail_WBS3", _
"detail_OwnerNumber", _
"detail_ClientNumber", _
"detail_CLAddress", _
"detail_WBS1", _
"detail_WBS2", _
"detail_WBS3" _
)
ct = UBound(q, 1)
''strkeyid (#,0) is the id
''strkeyif (#,1) is the 'position of the ID'
''strkeyid (#,2) is the data stored in teh current line for that id
ReDim strKeyID(ct, 1)
I = 0
For I = 0 To ct
strKeyID(I, 0) = q(I) ''key name
strKeyID(I, 1) = -1 ''key position
''strKeyID(I, 2) = "" ''temporary key data
Next ''I
End Sub
Function Reformat(Textline)
''if a line has quites, then there is a comma interfering with the string.. i.e. "lastname, firstname"
''looks for commas inside quotes and substitutes "_"
Dim I
Dim QTon ''quote on boolean
QTon = False
Dim aa
Reformat = ""
For I = 1 To Len(Textline)
aa = Mid(Textline, I, 1)
If aa = vbTab Then aa = "-" ''strip out native tabs
If aa = vbqt Then ''IF Quote character then
QTon = Not (QTon) ''flip QTON and drop the character
Else ''else NOT a quote character
If QTon Then ''Quote on = true then add the character
Reformat = Reformat + aa
Else ''quote on = false- we are outside quotes-
If aa = "," Then aa = vbTab ''substitute TAB for comma
Reformat = Reformat + aa ''Add subbed character
End If
End If
Next ''I
End Function
Sub Terminate(buttons)
If buttons = 0 Then buttons = vbOKOnly
On Error Resume Next
MyFile.Close
MsgBox "Script: " & wscript.ScriptFullName & vbCr & vbCr & _
StrMsg & vbCr & vbCr & _
"--Results---------------------------------" & vbCr & _
Right("0000" & DirLevels, 2) & " /LEVEL:(Dirlevels) Deep" & vbCr & _
Right("0000" & intFolderCt, 2) & " Folders Created" & vbCr & _
Right("0000" & intFolderRef, 2) & " Folders reviewed" & vbCr, buttons, "Convert Deltek To Folders Version:" & version
wscript.quit
End Sub
Function KGet(KeyID)
Dim I, xpos ''counter and x position in tab-delimited data
For I = 0 To UBound(strKeyID)
If KeyID = strKeyID(I, 0) Then
xpos = strKeyID(I, 1)
If xpos > 0 Then
KGet = strDataArr(xpos) ''get the position and return corresponding data from the split line array
Exit Function
Else
Exit For ''aware of key but <0 means undefined
End If
End If
Next I
KGet = Empty
End Function
Sub CreateFolders(strDataArr, ObjFso) '' As FileSystemObject)
If UBound(strDataArr) < strDataUB Then
StrMsg = StrMsg & vbCr & "Null Array Error in Create folder at folder count: " & intFolderRef & vbCr & "Str DATA LINE:" & vbCr & Textline & vbCr
Terminate (True)
End If
Dim ClientBill: ClientBill = KGet("detail_BillClientName")
Dim ClientName: ClientName = KGet("detail_ClientName") ''
Dim Projname: Projname = KGet("detail_WBS3") ''
Dim Owner: Owner = KGet("detail_OwnerName")
Dim OwnerNumb: OwnerNumb = KGet("detail_OwnerNumber")
''Project Number
Dim Prod: Prod = KGet("detail_WBS2")
Dim Disc: Disc = KGet("detail_WBS3")
Dim PCliNo: PCliNo = KGet("detail_OwnerNumber")
Dim Pnum: Pnum = KGet("detail_WBS1")
If Not IsEmpty(Pnum) Then
On Error Resume Next
Dim PYear, PCliRe, PCProd, count
''---regexp to break up ids in pnumber
Dim r, m
Set r = New RegExp
r.Pattern = "(\d{2})(\d{3})(\d{2})\.(\d{3})"
r.IgnoreCase = True
Set m = r.Execute(Pnum)
count = -1
count = m.count
If count > 0 Then
If m(0).SubMatches.count = 4 Then
PYear = m(0).SubMatches(0)
PCliNo = m(0).SubMatches(1)
PCliRe = m(0).SubMatches(2)
PCProd = m(0).SubMatches(3)
End If
Else
r.Pattern = "([a-z,A-Z]+)(\d{2})\.(\d{3})"
Set m = r.Execute(Pnum)
count = -1
count = m.count
If count > 0 Then
PCliNo = m(0).SubMatches(0)
PCliRe = m(0).SubMatches(1)
PCProd = m(0).SubMatches(2)
Else
r.Pattern = "([a-z,A-Z]+)\.(\d{3})"
r.IgnoreCase = True
Set m = r.Execute(Pnum)
count = -1
count = m.count
If count > 0 Then
PCliNo = m(0).SubMatches(0)
PCProd = m(0).SubMatches(1)
End If
End If
End If
End If
Dim FP: FP = strFPt
Dim objFolder ''As Folder
Dim Folder '' As Folder
Dim I ''counter
'''client
''base folder
FP = FP & PCliNo
If PCliNo = "" Then CreateFoldersCrash ("Project number")
If ClientName = "" Then ClientName = Projname
Set Folder = FolderCheck(FP, ObjFso, StrClean(ClientName & "(" & PCliNo & ")"))
If DirLevels = 0 Then Exit Sub ''limit folder creation at level 0 client
'''region folder
If PCliRe = "" Then Exit Sub ''CreateFoldersCrash ("Region missing")
FP = FP & "\" & PCliRe
Set Folder = FolderCheck(FP, ObjFso, StrClean(ClientName))
If DirLevels = 1 Then Exit Sub ''limit folder creation at level 1 region
'''Product
FP = FP & "\" & "-" & PCProd
Set Folder = FolderCheck(FP, ObjFso, StrClean("-" & Trim(PCProd) & Trim("-" & Prod)))
If DirLevels = 2 Then Exit Sub ''limit folder creation at level 2 Product
''Consultants -- using -1 for dir levels creates all consutlants
If DirLevels = -1 Then
For I = 1 To UBound(strDiscID, 1)
Set Folder = FolderCheck(FP & "\" & strDiscID(I, 1), ObjFso, StrClean(strDiscID(I, 2)))
Next 'I
Else ''Pass the value to CheckDiscipline
Call CheckDiscipline(FP, ObjFso, Disc)
End If
End Sub
Sub CreateFoldersCrash(Name)
MsgBox Name & " missing from report, exiting", vbCritical, "Missing info in report"
Terminate vbCritical
Exit Sub
End Sub
Function CheckDiscipline(FP, ObjFso, Disc)
Dim Folder
Dim I
Disc = Trim(Disc)
If RemapE And Disc = "E" Then Disc = "S" ''''<<<<<<<<<<<<<<<<<<<<<<<<<<<<<Exception to map "E" to "S" for now
If Disc > "" Then
For I = 1 To UBound(strDiscID)
If ReturnMatch(strDiscID(I, 1), ".*?" & Trim(Disc) & ".*?") > "" Then
Set Folder = FolderCheck(FP & "\" & strDiscID(I, 1), ObjFso, StrClean(strDiscID(I, 2)))
End If
Next ''I
Else
'''optional create all anyway
End If
End Function
Function StrClean(StrToClean)
StrToClean = UCase(StrToClean)
Dim I, a
For I = 1 To Len(StrToClean)
a = Mid(StrToClean, I, 1)
If a >= "A" And a <= "Z" Or a >= "0" And a <= "9" Or a = "(" Or a = ")" Then
StrClean = StrClean & a
ElseIf a = " " And Right(StrClean, 1) <> " " Then
StrClean = StrClean & a
ElseIf Right(StrClean, 1) <> "-" Then
StrClean = Trim(StrClean & "-")
End If
Next ''I
Do While Right(StrClean, 1) = "-" Or Right(StrClean, 1) = " "
StrClean = Left(StrClean, Len(StrClean) - 1)
Loop
End Function
Function FolderCheck(FP, ObjFso, xcutName)
On Error Resume Next
Set FolderCheck = ObjFso.GetFolder(FP)
intFolderRef = intFolderRef + 1
If FolderCheck Is Nothing Then
Set FolderCheck = ObjFso.CreateFolder(FP)
intFolderCt = intFolderCt + 1
End If
XCut FolderCheck, xcutName ''create xcut- if it exists it will be deleted and recreated.
End Function
Sub XCut(Folder, strXcutName)
Dim objScut
Dim FN
Do While (Right(strXcutName, 1) = " " Or Right(strXcutName, 1) = "-") And Len(strXcutName) > 2
strXcutName = Left(strXcutName, Len(strXcutName) - 1)
Loop
FN = Folder.ParentFolder.path + "\" + strXcutName + ".lnk"
If fso.FileExists(FN) Then fso.DeleteFile (FN)
Set objScut = objWSH.CreateShortcut(FN)
objScut.WindowStyle = 4 ''7=Minimized 0=Maximized 4=Normal
objScut.TargetPath = Folder.path
objScut.Save
End Sub
Function ReturnMatch(strStr, strMatch)
''VBA include Microsoft VBSCript Regular Expressions 5_5
Dim r 'As New RegExp ''Regexp engine
Dim m 'As MatchCollection ''Return value
Dim I, x()
'Dim StrMatch ''as pattern match
If InStr(1, strMatch, "(") + InStr(1, strMatch, ")") = 0 Then ''add () for subexpression to return something...
If Left(strMatch, 1) <> "(" Then strMatch = "(" & strMatch
If Right(strMatch, 1) <> ")" Then strMatch = strMatch & ")"
End If
Set r = New RegExp
r.Pattern = strMatch
r.IgnoreCase = True
Set m = r.Execute(strStr)
''Regexp os base-o arrays so info rturned starts at (0) not (1)
On Error Resume Next
If m.count = 0 Then
ReturnMatch = "" ''return null
Exit Function ''nomatch
Else
ReturnMatch = m(0).SubMatches(0) ''return 1st submatch
End If
End Function
Public Sub SetData(StrRdLn)
strDataArr = Split(StrRdLn, vbTab)
strDataUB = UBound(strDataArr)
End Sub
Sub SetKeyInit(StrRdLn)
Dim x
x = Split(StrRdLn, vbTab)
KeySet = True
Dim I, j
For I = 0 To UBound(x) ''assocaite positions in the array with data
For j = 0 To UBound(strKeyID, 1)
If strKeyID(j, 0) = x(I) Then
strKeyID(j, 1) = I ''store position of data
Exit For
End If
Next 'j
Next 'I
strKeyUB = UBound(x)
End Sub
%20t133819%20Microsoft_Visual_Studio.png)
Comments
Post a Comment