5
10
2
初来乍到
本帖以下内容被隐藏保护;需要你回复后,才能看到!
使用道具 举报
170
1424
8
顶梁支柱
'##################################### '# 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