碰撞检测

'#####################################
'# 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