Work is in progress, so will update this post as code gets out… to link the Excel 3DViewer and ammendments to code
Option Explicit Private Const MODULE_NAME As String = "mIFC" Private Type tXYZ X As Double Y As Double Z As Double End Type Private Type tPolyLoop Direction As tXYZ FaceOuterBound As Long Index() As Long End Type Private Type tIfcDeclaration hnd As Long IfcCode As String Parameters() As String End Type Private Sub sIFC_Geometry_Read() Dim FilePath As String FilePath = Application.GetOpenFilename("Ifc Files (*.ifc), *.ifc") If VBA.CVar(FilePath) = False Then MsgBox "File open failed" & VBA.IIf(FilePath, " [" & FilePath & "]", ". No file") Exit Sub End If Call fIFC_Geometry_Read(FilePath) End Sub Private Sub InsertionSort_Lng(ByRef Data() As Long) ' Best algorithm for an almost sorted array Dim lngCounter1 As Long, lngCounter2 As Long Dim DataTemp As Long For lngCounter1 = LBound(Data) To UBound(Data) DataTemp = Data(lngCounter1) For lngCounter2 = lngCounter1 To 1 Step -1 If Data(lngCounter2 - 1) > DataTemp Then Data(lngCounter2) = Data(lngCounter2 - 1) Else Exit For End If Next lngCounter2 Data(lngCounter2) = DataTemp Next lngCounter1 End Sub Private Function fIFC_Geometry_Read(ByVal FilePath As String) Dim aPtrs() As Long, cntIfc As Long Dim aIfcDeclarations() As tIfcDeclaration, aIfcDeclarations_() As tIfcDeclaration Dim Lines() As String, txtLine As String, cntLine As Long, cntLine_ As Long Dim IfcCode As String Dim cntItem As Long Dim cntCartesianPoint As Long, cntDirection As Long, _ cntFace As Long, cntFaceOuterBound As Long, cntPolyLoop As Long Dim aIfcPts() As tXYZ, aIfcDirections() As tXYZ, aIfcFaces() As tXYZ, aIfcPolyLoops() As tPolyLoop Dim ChrPos As Long Call fFile_Load(Lines(), FilePath) ' Get declarations(pointer/DeclarationType/Parameters) ReDim Preserve aIfcDeclarations(LBound(Lines) To UBound(Lines)) ReDim Preserve aPtrs(LBound(Lines) To UBound(Lines)) For cntLine = cntLine To UBound(Lines) Lines(cntLine) = VBA.Trim$(Lines(cntLine)) Next cntLine cntLine = LBound(Lines) Do Until VBA.Trim$(Lines(cntLine)) Like "DATA;" cntLine = cntLine + 1: If cntLine > UBound(Lines) Then Exit Do 'DoEvents Loop cntLine_ = UBound(Lines) Do Until VBA.Trim$(Lines(cntLine_)) Like "ENDSEC;" cntLine_ = cntLine_ - 1: If cntLine < LBound(Lines) Then Exit Do 'DoEvents Loop For cntLine = cntLine To cntLine_ txtLine = Lines(cntLine) If VBA.Left$(txtLine, 2) Like "/[*]" Then ' comment Do Until VBA.Right$(txtLine, 2) Like "[*]/" cntLine = cntLine + 1: If cntLine > UBound(Lines) Then Exit Do 'DoEvents Loop Else 'data... cntIfc = cntIfc + 1 ChrPos = VBA.InStr(1, txtLine, "=") aIfcDeclarations(cntIfc).hnd = VBA.CLng(VBA.Mid$(txtLine, 2, ChrPos - 2)) aPtrs(cntIfc) = aIfcDeclarations(cntIfc).hnd IfcCode = VBA.Mid$(txtLine, ChrPos) ChrPos = VBA.InStr(1, IfcCode, "(") aIfcDeclarations(cntIfc).IfcCode = VBA.Mid$(IfcCode, 1, ChrPos - 1) txtLine = VBA.Mid$(txtLine, ChrPos + 1) txtLine = VBA.Mid$(txtLine, 1, VBA.Len(txtLine) - 1) aIfcDeclarations(cntIfc).Parameters() = VBA.Split(txtLine, ",") End If 'DoEvents Next cntLine ReDim Preserve aIfcDeclarations(cntLine) ReDim Preserve aPtrs(cntLine) ' Sort declarations... by hnd value (best suited for the almost sorted array is the insertion sort) ' https://stackoverflow.com/questions/42598189/insertion-sort-in-vba-not-working aIfcDeclarations_() = aIfcDeclarations() Call InsertionSort_Lng(aPtrs) For cntLine = LBound(aPtrs) To UBound(aPtrs) aIfcDeclarations_(cntLine) = aIfcDeclarations(aPtrs(cntLine)) Next cntLine '--- cntCartesianPoint = -1 cntDirection = -1 cntCartesianPoint = -1 cntPolyLoop = -1 For cntLine = LBound(aIfcDeclarations_) To UBound(aIfcDeclarations_) '!!!!!!!!!!!! 'hnd = fIfcCode_BinarySearch(Target, aPtrs(), LBound(aPtrs), UBound(aPtrs)) '!!!!!!!!!!!! With aIfcDeclarations_(cntLine) If IfcCode Like "IFCCARTESIANPOINT" Then '#38 = IFCCARTESIANPOINT((4.30558740099853, 12.9543948697056, 9.)); cntCartesianPoint = cntCartesianPoint + 1: ReDim Preserve aIfcPts(0 To cntCartesianPoint) For cntItem = LBound(.Parameters) To UBound(.Parameters) Next cntItem ElseIf IfcCode Like "IFCDIRECTION" Then '#18 = IFCDIRECTION((0., 0., 1.)); cntDirection = cntDirection + 1: ReDim Preserve aIfcPts(0 To cntDirection) For cntItem = LBound(.Parameters) To UBound(.Parameters) Next cntItem ElseIf IfcCode Like "IFCFACE" Then '#240 = IFCFACE((#241)); cntFace = cntFace + 1: ReDim Preserve aIfcFaces(0 To cntCartesianPoint) For cntItem = LBound(.Parameters) To UBound(.Parameters) Next cntItem ElseIf IfcCode Like "IFCFACEOUTERBOUND" Then ''#241 = IFCFACEOUTERBOUND(#242, .T.); ' 'cntFaceOuterBound = cntFaceOuterBound + 1: ReDim Preserve aIfcPolyLoops(0 To cntFaceOuterBound) ' ' search for aPolyLoops... ElseIf IfcCode Like "IFCPOLYLOOP" Then '#242 = IFCPOLYLOOP((#40, #42, #54)); cntPolyLoop = cntPolyLoop + 1: ReDim Preserve aIfcPts(0 To cntPolyLoop) For cntItem = LBound(.Parameters) To UBound(.Parameters) Next cntItem Else '#29 = IFCCARTESIANPOINTLIST3D(((3.13934927250691, 10.0530219646776, 8.), (10.3358918702723, 11.1339255959626, 6.), (4.30558740099853, 12.9543948697056, 9.), (2.65578712166892, 16.4815540875827, 10.), (8.71453642334491, 16.7944472440073, 5.)), $); '#30 = IFCTRIANGULATEDIRREGULARNETWORK(#29, $, .F., ((3, 5, 4), (2, 5, 3), (3, 4, 1), (2, 3, 1)), $, (0, 0, -1, 0)); End If End With Next cntLine End Function Private Function fIfcCode_BinarySearch(ByVal Target As Long, _ ByRef aData() As Long, _ Optional ByVal nFirst As Long = 0, _ Optional ByVal nLast As Long = -1) As Long Dim nMiddle As Long, Value As Long If nFirst > nLast Then nFirst = LBound(aData) nLast = UBound(aData) End If If nFirst < LBound(aData) Then nFirst = LBound(aData) If nLast > UBound(aData) Then nLast = UBound(aData) Do While True If nFirst > nLast Then fIfcCode_BinarySearch = -1: Exit Do ' Failed to find search arg nMiddle = (nLast + nFirst) \ 2 Value = aData(nMiddle) If Value > Target Then nLast = nMiddle - 1 ElseIf Value < Target Then nFirst = nMiddle + 1 Else fIfcCode_BinarySearch = nFirst Exit Do End If Loop End Function