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