[编程交流] 热挤压3DFace对象i

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