hot to extrude 3DFace object into 3DSolid using vba

Hi All

we can create a 3D Face by using 4 points after that i want to extrude 3D Face object into solid can any one help me how to achieve it

case1: if the 4 points are in non coplanar

case2: if the 4 points are in coplanar

thanks in advance

Srikanth

A Region entity is needed to extrude a 3DSolid; and, as we’ve already determined, a region is a “Planar” entity. Consequently, your concern about the possibility of non-planar 3dFaces is valid.

Here is a portion of the requested routine (the routine gets complicated rather quickly) that will create the appropriate Region(s). It may be of some help.

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