Revit export shared parameters from Excel

So load your parameters file into excel but the export needs to remove null tabs at the ends.

Attribute VB_Name = "REVIT_EXPORT_PARAM_LIB" ''©2021 Ron E. Allen- Shared with KTGY2018-2019 - All rights reserved ''©2023 Ron E. Allen- Shared with WareMalcomb2019-2023 - All rights reserved Option Explicit Const VBQT = """" Sub REVIT_Shared_Params_EXPORT() Dim ws As Worksheet Dim objTxtFile As TextStream ''As Integer Dim filepath As String Dim strN As String Dim nRow As Integer Dim ncol As Integer Dim RowMax As Integer Dim ColMax As Integer Dim RColmax As Integer Dim strLine As String Dim strFmt As String Dim obj Dim CheckGroup As Range Dim GroupID_START As Integer Dim GroupID_END As Integer Dim FSO As FileSystemObject Dim objFile As File Dim curDate As Date Dim newDate As Date Dim boolParams As Boolean If MsgBox("This exports the ''PARAMS' worksheet, or ACTIVE worksheet in shared parameters format, in the same folder as the EXCEL file." & vbCr & vbCr & "Continue?", vbInformation + vbYesNo) <> vbYes Then MsgBox "Exiting", vbExclamation Exit Sub End If Set FSO = CreateObject("Scripting.FileSystemObject") On Error Resume Next Set ws = ActiveWorkbook.Worksheets("PARAMS") If ws Is Nothing Then Set ws = ActiveWorkbook.ActiveSheet If (MsgBox("Error opening " & VBQT & "PARAMS" & VBQT & " worksheet." & vbCr & vbCr & "OK to use " & ws.Name & " for export?", vbYesNo + vbCritical, "Cannot find 'PARAMS' worksheet") _ <> vbYes) Then Exit Sub End If End If RowMax = Cells.Find("*", [a1], xlFormulas, , xlByRows, xlPrevious).Row ColMax = 9 ''Currently max col until *META is largest from column groups - COLMAX set to 9 by default to start strN = Application.ActiveWorkbook.Name strN = Left(strN, InStr(Len(strN) - 5, strN, ".", vbTextCompare) - 1) ws.Activate Application.DisplayAlerts = False filepath = CheckFilepath(ws.Parent.Path & "\" & strN & ".txt") If FSO.FileExists(filepath) Then Set objFile = FSO.GetFile(filepath) curDate = objFile.DateLastModified End If FSO.DeleteFile (filepath) If FSO.FileExists(filepath) Then MsgBox "ERROR: File cannot be deleted." & vbCr & vbCr & "Check if it is read only, " & vbCr & vbCr & "-THEN-" & vbCr & vbCr & "Try closing revit and waiting for file to become available to read/write.", vbCritical Exit Sub End If On Error GoTo 0 ''fso text file- the textwrite has issues with uinicode and Kanji characters showing upp in lieu of ASCII '''https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/openobjTxtFile-method Set objTxtFile = FSO.CreateTextFile(filepath, True, False) ColMax = 1 ''reset so as not to accidentally write out unused data past col 1 For nRow = 1 To RowMax If Left(ws.Cells(nRow, 1), 1) = "#" Then ''special case comment field - target for remaining parameters ColMax = Cells(nRow, Columns.Count).End(xlToLeft).Column ''10 ''last cell in column! Else Select Case UCase(ws.Cells(nRow, 1)) ''Break out right-hand limits for content with fewer columns Case "*META" '', "META" ''Al META under *META ColMax = shtParams.ListObjects("META").Range.Columns.Count ''params Parameter table BY NAME META ColMax = 3 Case "*GROUP" '', "GROUP" ''all "GROUP" under "*GROUP" ColMax = shtParams.ListObjects("groups").Range.Columns.Count ''params Parameter table BY NAME GroupID_START = nRow + 1 Case "*PARAM" '', "PARAM" ''All PARAM under *PARAM boolParams = True 'flag for last section of parameters ColMax = shtParams.ListObjects("Parameters").Range.Columns.Count ''params Parameter table BY NAME GroupID_END = Cells.Find("*", ws.Cells(nRow, 2), xlFormulas, , xlByColumns, xlPrevious).Row ''Use the final range to set the check group Set CheckGroup = ws.Range(ws.Cells(GroupID_START, 2), ws.Cells(GroupID_END, 2)) Case "" ColMax = 1 End Select End If strLine = "" ''For each of the used columns repeat the export For ncol = 1 To ColMax If ncol > ColMax Then Exit For ''for pseudo to truncate junk outside the max col and allow for notes. strFmt = ws.Cells(nRow, ncol).NumberFormat If strFmt Like "General" Then strFmt = "" strLine = strLine & Format(ws.Cells(nRow, ncol).Value, strFmt) & vbTab Next ncol ''this strips off empty tabs from the end of each line. ''This is the cheap and fast way to export a relatively correctly formattted file Do While Right(strLine, 1) = vbTab And strLine <> "" strLine = Left(strLine, (Len(strLine) - 1)) Loop '''Print #objTxtFile, strLine & vbCrLf objTxtFile.Write (strLine & vbCrLf) Next nRow ''Close objTxtFile objTxtFile.Close Set FSO = Nothing Set FSO = CreateObject("Scripting.FileSystemObject") If FSO.FileExists(filepath) Then Set objFile = FSO.GetFile(filepath) newDate = objFile.DateLastModified If curDate = newDate Then MsgBox "File did not update; May require closing revit and updateing the file.", vbOKOnly + vbExclamation, "Warning" Else MsgBox "File Appears to have updated successfully at " & Format(newDate, "yyyy-mm-ddthh:mma/p"), vbOKOnly + vbInformation, "Success" VBA.Shell "C:\windows\explorer.exe /select, " & VBQT & filepath & VBQT, vbNormalFocus End If End If End Sub 'Private Function ListObjExists(wkSht As Worksheet, strName As String) As Boolean ' Dim x As ListObject ' On Error Resume Next ' Set x = wkSht.ListObjects(strName) ' On Error GoTo 0 ' If x Is Null Then ListObjExists = False Else ListObjExists = True 'End Function Function CheckFilepath(ByRef filepath) ''subs out sharepoint filepath for 'local' If LCase(filepath) Like "http*sharepoint*" Then ''Sharepoint hack to try to rewrite to local drive path... If filepath Like "http*/Documents/*" Then ''we can take a guess to the local locaiton filepath = Environ$("USERPROFILE") & "\OneDrive - Ware Malcomb\Documents" & Right(filepath, Len(filepath) - 18 - InStr(1, filepath, "documents/", vbTextCompare)) filepath = Replace(filepath, "/", "\", 1, -1, vbTextCompare) Else MsgBox "Cannot save to OneDrive, malformed path. OK to cancel", vbCritical + vbOKOnly, "Malformed path - Onedrive" End If ''Stop ''redirect to local ... End If CheckFilepath = filepath End Function ''==============validate parameters lists '' lines starting with # are comments and can appear anywhere ''blank lines can appear anywhere ''there emust be a META section ''leave it alone! ''There mus tbe a Groups table ''group col 1 ''integer col 2 ''name col 3 ''There must be a PARAM table ''param col 1 ''GUID col 2 ''name col 3 ''datatype col 4 ''data category col 5 = empty typically ''group - must match integer in ID in gorup ''visible must be 0 or 1 '' Description optional ''User modifiable - typically 1 but may be 0 ''If a # is added in front of the "Date modified - all data afterwards becomes comments and ignored by REvit ''end of reference '======================================================================== Sub REVIT_EXPORT_CATALOG_1st_row_params() Dim ws As Worksheet Dim objTxtFile As TextStream ''As Integer Dim filepath As String Dim strN As String Dim nRow As Integer Dim ncol As Integer Dim RowMax As Integer Dim ColMax As Integer Dim strLine As String Dim strFmt As String If MsgBox("This exports the entire catalog from the 'EXPORT' tab using the first row as parameters. Continue?", vbInformation + vbYesNo) <> vbYes Then MsgBox "Exititng", vbExclamation Exit Sub End If Dim FSO As FileSystemObject Set FSO = CreateObject("Scripting.FileSystemObject") Set ws = ActiveWorkbook.Worksheets(1) ' RowMax = Cells.Find("*", [a1], xlFormulas, , xlByRows, xlPrevious).Row ColMax = Cells.Find("*", [a1], xlFormulas, , xlByColumns, xlPrevious).Column strN = ThisWorkbook.Name strN = Left(strN, InStr(Len(strN) - 5, strN, ".", vbTextCompare) - 1) ws.Activate Application.DisplayAlerts = False filepath = UCase(ws.Parent.Path & "\" & strN) & ".csv" If VBA.Dir(ws.Parent.Path & "\" & strN & ".csv") <> "" Then FSO.DeleteFile (ws.Parent.Path & "\" & strN & ".csv") ''fso text file- the textwrite has issues with uinicode and Kanji characters showing upp in lieu of ASCII '''https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/openobjTxtFile-method Set objTxtFile = FSO.CreateTextFile(filepath, True, False) RowMax = ws.Cells(Rows.Count, 1).End(xlUp).Row ColMax = ws.Cells(1, Columns.Count).End(xlToLeft).Column For nRow = 1 To RowMax strLine = "" For ncol = 1 To ColMax If nRow = 1 And ncol = 1 Then ''null for upper left cell always! strLine = strLine & "," Else strFmt = ws.Cells(nRow, ncol).NumberFormat If strFmt Like "General" Then strFmt = "" strLine = strLine & Format(ws.Cells(nRow, ncol).Value, strFmt) & "," End If Next ncol strLine = Left(strLine, Len(strLine) - 1) '''Print #objTxtFile, strLine & vbCrLf objTxtFile.Write (strLine & vbLf) Next nRow ''Close objTxtFile objTxtFile.Close Set FSO = Nothing If VBA.Dir(ws.Parent.Path & "\" & strN & ".csv") <> "" Then MsgBox ":File Exists- Please verify Success writing: " & vbCr & vbCr & filepath, vbInformation VBA.Shell "C:\WINDOWS\explorer.exe """ & ws.Parent.Path & "", vbNormalFocus Else MsgBox "Error writing", vbCritical End If End Sub Sub REVIT_EXPORT_CATALOG_1strow_mapped_params() Dim ws As Worksheet Dim objTxtFile As TextStream ''As Integer Dim filepath As String Dim strN As String Dim nRow As Integer Dim ncol As Integer Dim RowMax As Integer Dim ColMax As Integer Dim strLine As String Dim strFmt As String Dim cols As New Collection Dim obj Dim FSO As FileSystemObject If MsgBox("This exports catalogs using the first row of the 'EXPORT' tab." & vbCr & vbCr & _ "Parameters will skip the second row and use the corresponding values from column1 (family name) & marked columns." & vbCr & vbCr & _ "Continue?", vbInformation + vbYesNo) <> vbYes Then MsgBox "Exititng", vbExclamation Exit Sub End If Set FSO = CreateObject("Scripting.FileSystemObject") On Error Resume Next Set ws = ActiveWorkbook.Worksheets("EXPORT") If ws Is Nothing Then MsgBox "Error opening " & VBQT & "EXPORT" & VBQT & " worksheet." & vbCr & "Exiting.", vbCritical Exit Sub End If RowMax = Cells.Find("*", [a1], xlFormulas, , xlByRows, xlPrevious).Row ColMax = Cells.Find("*", [a1], xlFormulas, , xlByColumns, xlPrevious).Column strN = Application.ActiveWorkbook.Name strN = Left(strN, InStr(Len(strN) - 5, strN, ".", vbTextCompare) - 1) ws.Activate Application.DisplayAlerts = False filepath = UCase(ws.Parent.Path & "\" & strN) & ".csv" FSO.DeleteFile (filepath) If FSO.FileExists(filepath) Then MsgBox "ERROR: File cannot be deleted." & vbCr & vbCr & "Check if it is read only, " & vbCr & vbCr & "-THEN-" & vbCr & vbCr & "Try closing revit and waiting for file to become available to read/write.", vbCritical Exit Sub End If On Error GoTo 0 ''fso text file- the textwrite has issues with uinicode and Kanji characters showing upp in lieu of ASCII '''https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/openobjTxtFile-method Set objTxtFile = FSO.CreateTextFile(filepath, True, False) RowMax = ws.Cells(Rows.Count, 1).End(xlUp).Row ColMax = ws.Cells(1, Columns.Count).End(xlToLeft).Column ''Stop ''Look at first row for non-blank parameters For ncol = 1 To ColMax If ws.Cells(1, ncol).Value > "" Or ncol = 1 Then cols.Add (ncol) ''add first column-assuming family name and any column with data in 1st row Next ncol For nRow = 1 To RowMax If nRow = 2 Then nRow = 3 ''skip row 2 strLine = "" ''For each of the used columns repeat the export For Each obj In cols ncol = obj If nRow = 1 And ncol = 1 Then ''null for upper left cell always! strLine = strLine & "," Else strFmt = ws.Cells(nRow, ncol).NumberFormat If strFmt Like "General" Then strFmt = "" strLine = strLine & Format(ws.Cells(nRow, ncol).Value, strFmt) & "," End If Next obj strLine = Left(strLine, Len(strLine) - 1) '''Print #objTxtFile, strLine & vbCrLf objTxtFile.Write (strLine & vbLf) Next nRow ''Close objTxtFile objTxtFile.Close Set FSO = Nothing If VBA.Dir(ws.Parent.Path & "\" & strN & ".csv") <> "" Then MsgBox ":File Exists- Please verify Success writing: " & vbCr & vbCr & filepath, vbInformation VBA.Shell "C:\WINDOWS\explorer.exe """ & ws.Parent.Path & "", vbNormalFocus Else MsgBox "Error writing", vbCritical End If End Sub Function WorksettNameAndPath() WorksettNameAndPath = ThisWorkbook.FullName End Function

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