Read Ifc geometry info with VBA

Following is simple code to read a Ifc file structure and get the basic geometry information stored on it, which can then feed the Excel 3Dviewer.

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