Convert Deltek Report (CSV, TXT) to folder structure based on indexing of NCS4.0
This code takes a CSV formatted report from Deltek and looks for key variables in the report header to create a folder structure. In lieu of long folder names it creates numbers and descriptive shortcuts to the folders. VBS Code below:
Option Explicit
Const version =
"v2014-09-03-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 ''
'''Deltek Variables stores index of variables based on
Dim kCliBillName '', "Billing Client Name", -1
Dim kCliContact '', "Billing Contact Name", -1
Dim kCliAddress '', "Client Address", -1
Dim kCliName '', "Client Name", -1
Dim kCliNameContact '',
"Contact Name", -1
Dim kLocale '', "Locale", -1
Dim kProjNamelong '', "LongName", -1
Dim kProjNameshort '',
"Name", -1
Dim kOwnerName '', "Owner Name", -1
Dim kOwnerNumber '', "Owner Number", -1
Dim kProj '', "Project", -1
Dim kProd '', "Product/Phase", -1
Dim kdisc '', "Discipline", -1
''FILE MANIPULATION OBJECTS AND
REFERENCES''''''''''''''''''
Dim fso ''As New FileSystemObject for creating folders
Dim objWSH ''As New WshShell for creating shortcuts
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 report in deltek
and 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
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
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 = strDataArr(kCliBillName)
Dim ClientBillCon: ClientBillCon
= strDataArr(kCliContact)
Dim ClientName:
ClientName = strDataArr(kCliName)
Dim Contact: Contact =
strDataArr(kCliNameContact)
''Const kLocale = "detail_Locale"
Dim Projame: Projame =
strDataArr(kProjNamelong)
Projame =
Projame & strDataArr(kProjNameshort) ''prefix short name onto long name was mix of both in list
Dim Owner: Owner =
strDataArr(kOwnerName)
Dim OwnerNumb: OwnerNumb =
strDataArr(kOwnerNumber)
''Project Number
Dim Pnum: Pnum =
strDataArr(kProj)
Dim PYear: PYear =
Mid(Pnum, 1, 2)
Dim PCliNo: PCliNo =
Mid(Pnum, 3, 3)
Dim PCliRe: PCliRe =
Mid(Pnum, 6, 2)
Dim PCProd: PCProd =
Mid(Pnum, 9, 3)
Dim Prod: Prod =
strDataArr(kProd)
Dim Disc: Disc =
strDataArr(kdisc)
''If PCliNo > "002" Then Stop
Dim FP: FP =
strFPt
Dim objFolder ''As Folder
Dim Folder '' As Folder
Dim I ''counter
'''client
''base folder
FP = FP &
PCliNo
Set Folder = FolderCheck(FP,
ObjFso, StrClean(ClientName & "-" &
PCliNo))
If DirLevels = 0 Then Exit Sub ''limit folder creation at level 0 client
'''region folder
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
Function
CheckDiscipline(FP, ObjFso, Disc)
Dim Folder
Dim I
Disc =
Trim(Disc)
If RemapE And Disc = "E" Then Disc = "S" ''''<<<<<<<<<<<<<<<<<<<<<<<<<<<<
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
For I = 1 To UBound(x)
Select Case UCase(x(I))
Case UCase("detail_BillClientName")
kCliBillName
= I
Case UCase("detail_billContactName")
kCliContact =
I
Case UCase("detail_CLAddress")
kCliAddress =
I
Case UCase("detail_ClientName")
kCliName =
I
Case UCase("detail_ContactName")
kCliNameContact = I
Case UCase("detail_Locale")
kLocale =
I
Case UCase("detail_LongName")
kProjNamelong = I
Case UCase("detail_Name")
kProjNameshort = I
Case UCase("detail_OwnerName")
kOwnerName =
I
Case UCase("detail_OwnerNumber")
kOwnerNumber
= I
Case UCase("detail_WBS1")
kProj =
I
Case UCase("detail_WBS2")
kProd =
I
Case UCase("detail_WBS3")
kdisc =
I
End Select
Next ''I
strKeyUB =
UBound(x)
End Sub
Comments
Post a Comment