Wednesday, February 25, 2015

Improved Deltek "Keyed data" (eport report to CSV) to create folder structure

 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  

Friday, February 13, 2015

Revit nested family not hosting to "Pick primary host" option in "Stacked wall" condition

Revit nested family not hosting to "Pick primary host" option in "Stacked wall" condition- nested family floats out beyond wall to stacked wall width.

The issue was resolved by hosting the nested family to a reference plan then aligning & locking the reference plane to the wall face's finish.

reloading correctly shrunk up the gap between the nested family and the "Primary host"

Monday, February 9, 2015

Thursday, February 5, 2015

On the Road to VDC Integration~ Geeking out over Revit and MS Access data connections...

On the Road to VDC Integration~ Geeking out over Revit and MS Access data connections...
Personal breakthrough- I finally got an great connection from Revit 2015 to MS Access through a plugin called DBConnect. 
I had to install the ODBCx64 drivers downloaded from Microsoft as even whn I installed the x64 version of office to go with my x64bit everythign else it insisted on rverting to teh x32 ODBC drivers:
http://www.microsoft.com/en-us/download/details.aspx?id=23734 i got from this very useful dude!~
Found this helpful9
Answer
Scottgem replied on 

You can download the drivers here:

http://www.microsoft.com/downloads/details.aspx?familyid=7554F536-8C28-4598-9B72-EF94E038C891&displaylang=e

This file will add Access to the list of file types in the ODBC administrator.

Not sure if its 32 or 64 bit. But it worked on a machine running 64bit Win 7


Hope this helps, Scott<> P.S. Please post a response to let us know whether our answer helped or not. Microsoft Access MVP 2009 Author: Microsoft Office Access 2007 VBA Technical Editor for: Special Edition Using Microsoft Access 2007 and Access 2007 Forms, Reports and Queries
Hope this helps,
Scott<>
Blog: http://scottgem.wordpress.com
Microsoft Access MVP since 2007

Once installed I could use the ODBC connection to create a new export from the current Project.

This exported the nearly 300 database tables of information from Revit. I was then able to create reports from these tables to summarize information from the Revit model.

EXCEL- Holy... Much to my surprise...
I decided to link the information into Excel office 365 as data links. I created a Pivot table of walls and then added areas from another walls table tabulations for wall areas instantly appeared! I about passed out (Probably should not have skipped lunch  8-p

If we use the database to gather and consolidate the information that information and adjustments in it can possibly round-trip back into Revit as well... Don't need Bimlink or any of those others : )

Amazing linking and data available for extraction for any number of possible applications... and it is all finally working on x64bit Revit & MSOffice.