社区 › Auto Lisp › 热挤压3DFace对象i

srikanthkamuju 发表于 2022-7-6 11:24:06

热挤压3DFace对象i

大家好
 
我们可以通过使用4个点来创建一个三维面，然后我想将三维面对象挤出到实体中，有人能帮我实现吗
 
情况1：如果4个点不共面
 
情况2：如果4个点共面
 
提前感谢
斯里坎特

SEANT 发表于 2022-7-6 13:14:12

需要一个区域实体来挤出三维实体；正如我们已经确定的，一个区域是一个“平面”实体。因此，您对非平面3dFaces可能性的担忧是有效的。
 
这是所请求例程的一部分（例程变得相当复杂），它将创建适当的区域。这可能会有所帮助。
 
Sub RegionFrom3DFace()
Dim varPkPt As Variant
Dim ent As AcadEntity

With ThisDrawing

   .Utility.GetEntity ent, varPkPt, "Select a 3dFace: "
   If Not TypeOf ent Is Acad3DFace Then Exit Sub
   Dim entFace As Acad3DFace
   
   Dim varRegion As Variant
   Dim varCoords As Variant
   Dim bln3Sided As Boolean
   Dim blnFlat As Boolean
   Dim i As Integer, j As Integer
   Dim pts(3) As Variant
   Dim pt(2) As Double
   Dim dblInitVect() As Double
   Dim dblNextVect() As Double
   Set entFace = ent
   varCoords = entFace.Coordinates
   For i = 0 To 3
      For j = 0 To 2
         pt(j) = varCoords(j + (i * 3))
      Next
   pts(i) = pt
   Next
   bln3Sided = CompPTs(pts(2), pts(3), 0.000001)
   dblInitVect = VectorCross(VectorFrom2Pts(pts(0), pts(1)), _
                   VectorFrom2Pts(pts(0), pts(2)))
   dblNextVect = VectorCross(VectorFrom2Pts(pts(0), pts(2)), _
                   VectorFrom2Pts(pts(0), pts(3)))
   blnFlat = IsVectorZero(VectorCross(dblInitVect, dblNextVect))
   
   If bln3side Then
      Dim ents(2) As AcadEntity
      For i = 0 To 2
         Set ents(i) = .ModelSpace.AddLine(pts(i), pts((i + 1) Mod 2))
      Next
      varRegion = .ModelSpace.AddRegion(ents)
   Else
      If blnFlat Then
         Dim ents3(3) As AcadEntity
         For i = 0 To 3
            Set ents3(i) = .ModelSpace.AddLine(pts(i), pts((i + 1) Mod 4))
         Next
         varRegion = .ModelSpace.AddRegion(ents3)
      Else
         Dim ents1(2) As AcadEntity
         Dim ents2(2) As AcadEntity
         Dim varRegs2 As Variant
         For i = 0 To 2
            Set ents1(i) = .ModelSpace.AddLine(pts(i), pts((i + 1) Mod 3))
         Next
         For i = 0 To 1
            Set ents2(i) = .ModelSpace.AddLine(pts(i + 2), pts((i + 3) Mod 4))
            
         Next
         Set ents2(2) = ents1(2)
         varRegion = .ModelSpace.AddRegion(ents1)
         varRegs2 = .ModelSpace.AddRegion(ents2)
      End If
   End If
End With
End Sub

Function CompPTs(dblPt1 As Variant, dblPt2 As Variant, dblTol As Double) As Boolean
CompPTs = False
If Abs(dblPt1(0) - dblPt2(0)) < dblTol Then
   If Abs(dblPt1(1) - dblPt2(1)) < dblTol Then
      If Abs(dblPt1(2) - dblPt2(2)) < dblTol Then
         CompPTs = True
      End If
   End If
End If
End Function

Function VectorFrom2Pts(dbl1stPt As Variant, dbl2ndPt As Variant) As Double()
Dim dblDummy(0 To 2) As Double
dblDummy(0) = dbl2ndPt(0) - dbl1stPt(0)
dblDummy(1) = dbl2ndPt(1) - dbl1stPt(1)
dblDummy(2) = dbl2ndPt(2) - dbl1stPt(2)
VectorFrom2Pts = dblDummy
End Function

Public Function VectorCross(dblVect1() As Double, dblVect2() As Double) As Double()
Dim dblDummy(0 To 2) As Double
dblDummy(0) = dblVect1(1) * dblVect2(2) - dblVect1(2) * dblVect2(1)
dblDummy(1) = dblVect1(2) * dblVect2(0) - dblVect1(0) * dblVect2(2)
dblDummy(2) = dblVect1(0) * dblVect2(1) - dblVect1(1) * dblVect2(0)
VectorCross = dblDummy
End Function

Function IsVectorZero(dblVector() As Double, Optional lngPrecision As Long = 6) As Boolean
IsVectorZero = False
If Round(dblVector(2), lngPrecision) <> 0# Then Exit Function
If Round(dblVector(1), lngPrecision) <> 0# Then Exit Function
If Round(dblVector(0), lngPrecision) <> 0# Then Exit Function
IsVectorZero = True
End Function

查看完整版本: 热挤压3DFace对象i