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 codeOption 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