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

Popular posts from this blog

Powerpoint countdown and current time in slides VBA

Add text fields- this VBA searches through the objects in the first frame until it finds " " in the text some where, truncates everything from and to the right and replaces it with an active countdown timer or current time in the box. Refreshes every 500ms with a prtsafe call so it doesn't bog down the CPU. Add a slide advance to start the next slide and begin automated slide advancement. Attribute VB_Name = "Countdown" Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long Public Sub Wait ( Seconds As Double ) ''non cpu-intensive wait timer '' https://stackoverflow.com/questions/57268161/sleep-wait-timer-in-powerpoint-vba-thats-not-cpu-intensive Dim endtime As Double endtime = DateTime.Timer + Seconds Do WaitMessage DoEvents Loop While DateTime.Timer < endtime End Sub Sub Countdown_from_Start () Dim Time As Date Dim Count As ...
Read more

Revit area plans adding new types and references (Gross and rentable)

Image
Note to self: Add additional (duplicate) gross area and net area schemed under Area Plans And Area schemes... Really counter-intuitive place to put this instead of say...  Area Plans> New Type> Edit Type (ADD) or Create an area plan, then Go to Properties, Edit Type and Duplicate... Always seem to forget this one! 2015-10-16-And for the calculation type... To update: this also applies to Revit as well as LT- The gross calculations cannot be overridden, however the 'rentable' comes in various flavors... From AD Revit help: Applies to Revit LT 2015 Rules are determined by one type of space bordering another space. The following table shows area measurement rules. To find the appropriate measurement rule, find the selected Area Type and the corresponding Bordering Area Type. Gross Building Area Scheme Types Gross Building Area Scheme Types Area Type Selected Bordering Area Type Measurement Rule Gross Building Area Gross Buil...
Read more