碰撞检测
**** Hidden Message ***** 不。您必须检查每个块是否存在固体，然后将每个块引用与模型空间的其余部分进行检查。（当然，您可以检查块本身中的冲突。）
一个更简单的方法，尽管很乱，是分解块引用（这使块引用保持不变）将它们添加到数组中并删除不冲突的。
您能解释一下。
如何分解块引用并保持块引用不变？什么是blockref？是积木本身吗？
就像CmdrDuh说的，一个块就像一个对象列表，它们相对于零的位置。
块和块引用是完全不同的，你需要掌握差异才能编写成功的代码。
尝试使用分解的小子，然后查看结果。 在花了更多的时间之后，感觉“足够好”，可以与你们分享产品。
请参阅代码 + 结果窗口的附件。
下面是代码。我用我的SSet和Arrays愚弄了一下。对我来说，感觉一定有一种更简单的方法来处理这个问题。但是，某些函数不接受数组，而其他函数则不接受 Sset。
'#####################################
'# 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 Counter0 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
页:
[1]