Open catalogs, manage them then re-Export Revit Catalogs from Excel

Attribute VB_Name = "REVIT_EXPORT_CATALOG" ''2023 Ron E. Allen - Share with WM under general use license ''Required reference "Microsoft scripting runtime" for FSO and text streams Option Explicit Const VBQT = """" ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 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 location 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 '======================================================================== Sub REVIT_EXPORT_CATALOG_1st_row_params() Dim ws As Worksheet Dim objTxtFile As TextStream ''As Integer 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 strOut As String ''output + Check for "," in values to wrap in "" Dim dateOrigin As Date ''original date modified - if this doesn't' change then it didn't update Dim strWBname As String strWBname = ActiveWorkbook.Worksheets(1).Name '''''"ANNO-__-Code-Fixt-Calc" Dim fso As FileSystemObject Set fso = CreateObject("Scripting.FileSystemObject") Dim fnTargetWriteTXT As String ''csv output name fnTargetWriteTXT = ThisWorkbook.Worksheets(1).Parent.Path & "\" & strWBname & ".txt"
If MsgBox("Export entire catalog from '" & strWBname & "'tab?" & vbCr & "(This will overwrite the txt file.)", vbInformation + vbYesNo) <> vbYes Then MsgBox "Exititng", vbExclamation Exit Sub End If Set ws = ActiveWorkbook.Worksheets(1) ''Set 1st worksheet as active. ws.Activate 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) Application.DisplayAlerts = False ''filepath = UCase(ws.Parent.Path & "\" & strN) & ".csv" If VBA.Dir(fnTargetWriteTXT) <> "" Then dateOrigin = fso.GetFile(fnTargetWriteTXT).DateLastModified fso.DeleteFile (fnTargetWriteTXT) Else dateOrigin = -1 ''file doesn't exist End If '''https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/openobjTxtFile-method Set objTxtFile = fso.CreateTextFile(fnTargetWriteTXT, 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 = "" strOut = "" strOut = ws.Cells(nRow, ncol).Value ''If Left(strOut, Len("A-3 Amusement")) = "A-3 Amusement" Then Stop ''DEBUG Long string issue ''If ncol = 31 Then Stop If InStr(1, strOut, ",", vbTextCompare) _ Or InStr(1, strOut, Chr(10), vbTextCompare) _ Or InStr(1, strOut, Chr(13), vbTextCompare) _ Then ''Escapeable caharcters wrap in quotes strOut = VBQT & strOut & VBQT ''wrap in quotes strLine = strLine & strOut & "," ''Write out as quoted entire line Else strLine = strLine & Format(strOut, strFmt) & "," End If 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 VerifyWrite fnTargetWriteTXT, dateOrigin ''check against output and exist and date origin Application.DisplayAlerts = True End Sub Sub VerifyWrite(fn As String, Optional dateOrigin As Date = -1) Dim fso As New FileSystemObject If fso.FileExists(fn) Then If fso.GetFile(fn).DateLastModified > dateOrigin Then VBA.Shell "C:\WINDOWS\explorer.exe /select, """ & fn & "", vbNormalFocus MsgBox "See explorer window for updated file.", vbInformation + vbOKOnly, "Success!" Else MsgBox "File appears to have failed to update." & vbCr & "Please vheck file path/location is writeable, the file is closed, and try again." & vbCr & vbCr & fn, vbCritical + vbOKOnly, "Output error" End If Exit Sub Else MsgBox "Please check folder is writeable. " & vbCr & vbCr & fn, vbCritical + vbOKOnly, "File does not exist" End If 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