After spending some more time on this it feels 'good enough' to share the product with you guys.
See attachment for code + results window.
Here is the code. I fooled around a little with my SSets and Arrays. To me it feels like there must be an easier way to handle this. Some functions however would not accept Arrays and others not Ssets.
'#####################################
'# ClashDetect creates 3D solids from
'# selected 3D solids where they
'# interfere with eachother
'# Sub by J.v.d.Staaij
'# V1.0
'#####################################
Sub ClashDetect()
'original
Dim originalItems As AcadSelectionSet
'copy
Dim copyItem As AcadEntity
Dim CopiedItemsSSet As AcadSelectionSet
'explode
Dim TempEntity As AcadEntity
Dim TempItem As Variant
Dim TempArray(0 To 0) As AcadBlockReference
Dim Counter As Integer
Dim TempSubEntity As Acad3DSolid
'clas detect
Dim ClashSolid As Acad3DSolid
Dim newLayer, oldLayer
Dim ChecksExecuted As Long
Dim FoundClash As Long
Dim counterNotChecked As Long
Dim SolidCreationErrorCount As Long
'pre check
Dim obj1 As AcadEntity
Dim obj2 As AcadEntity
Dim pmin As Variant
Dim pmax As Variant
Dim qmin As Variant
Dim qmax As Variant
Dim Clash As Integer
'Let user select items
Set originalItems = ThisDrawing.SelectionSets.Add("block")
originalItems.SelectOnScreen
'Create templayer
Set tempLayer = ThisDrawing.Layers.Add("TEMPLAYER")
'Jumpout when nothing selected
If originalItems.Count = 0 Then GoTo Einde
'define dynamic copyarray
ReDim copyArray(0 To originalItems.Count - 1) As AcadEntity
'copy each item in original selection
For i = 0 To originalItems.Count - 1
Set copyItem = originalItems(i).Copy()
copyItem.Layer = "TEMPLAYER"
Set copyArray(i) = copyItem
Next
'create copy selectionset
Set CopiedItemsSSet = ThisDrawing.SelectionSets.Add("ArrayName")
'store copyarray in selectionset
CopiedItemsSSet.AddItems copyArray
'Explode blockrefs (and re-explode if necesary)
ExplodeAgain:
Counter = 0
For Each TempEntity In CopiedItemsSSet
If TypeOf TempEntity Is AcadBlockReference Then
Set TempArray(0) = TempEntity
CopiedItemsSSet.RemoveItems TempArray
TempItem = TempEntity.Explode
TempEntity.Delete
CopiedItemsSSet.AddItems (TempItem)
Counter = Counter + 1
End If
Next
If Counter <> 0 Then GoTo ExplodeAgain
'store currenty layer
Set oldLayer = ThisDrawing.ActiveLayer
'create layer for clashing items
Set newLayer = ThisDrawing.Layers.Add("DetectedClash")
ThisDrawing.ActiveLayer = newLayer
ThisDrawing.ActiveLayer.color = 6
'Set results counters
ChecksExecuted = 0
FoundClash = 0
counterNotChecked = 0
For i = 0 To CopiedItemsSSet.Count - 1
'Check if item is 3D Solid
If Not (CopiedItemsSSet(i).ObjectName = "AcDb3dSolid") Then
counterNotChecked = counterNotChecked + 1
GoTo SkipCheckObject
End If
' start checking
For j = i + 1 To CopiedItemsSSet.Count - 1
If Not (CopiedItemsSSet(j).ObjectName = "AcDb3dSolid") Then GoTo SkipCheckAgainst 'Check if against-item is 3D Solid
If Not (CopiedItemsSSet(i) Is CopiedItemsSSet(j)) Then 'Don't do self check
'Do pre check (easier for acad to compare bounding boxes (10-20x faster))
CopiedItemsSSet(i).GetBoundingBox pmin, pmax
CopiedItemsSSet(j).GetBoundingBox qmin, qmax
Clash = 0
For k = 0 To 2
limiet = (pmax(k) - pmin(k) + qmax(k) - qmin(k))
afstand = Abs(pmax(k) + pmin(k) - qmax(k) - qmin(k))
If afstand < limiet Then
Clash = Clash + 1
End If
Next k
If Clash = 3 Then ' Precheck is true
On Error GoTo ErrorSolidCreate 'Take care of Modeling Operation Errors
Set ClashSolid = CopiedItemsSSet(i).CheckInterference(CopiedItemsSSet(j), True)
On Error GoTo ErrorTrap
' set found clash to DetectedClash layer
If Not (ClashSolid Is Nothing) Then
ClashSolid.Layer = "DetectedClash"
FoundClash = FoundClash + 1
End If 'Not (ClashSolid Is Nothing) Then
ChecksExecuted = ChecksExecuted + 1
End If 'If Clash = 3 Then
Else
End If 'If Not (CopiedItemsSSet(i) Is CopiedItemsSSet(j)) Then 'Don't do self check
SkipCheckAgainst:
Next
SkipCheckObject:
Next
'result window
ClashDetectResults.Results.Caption = "" & ChecksExecuted & vbCrLf & _
FoundClash & vbCrLf & _
counterNotChecked & vbCrLf & _
SolidCreationErrorCount & ""
ClashDetectResults.Show
'Restore original layer
ThisDrawing.ActiveLayer = oldLayer
'delete templayer
'ThisDrawing.Layers.Delete (TO DO)
'Error trapping
ErrorTrap:
CopiedItemsSSet.Erase
CopiedItemsSSet.Delete
Einde:
originalItems.Delete
Exit Sub
ErrorSolidCreate:
SolidCreationErrorCount = SolidCreationErrorCount + 1
Resume Next
End Sub