Option Explicit
Private Const Pi  As Double = 3.14159265358979

Property Get Zero() As Variant
    Dim z2(2) As Double
    Zero = z2
End Property

Sub FlattenThis(Ent As AcadEntity)
   
    Dim oLine As AcadLine
    Dim oMline As AcadMLine
    Dim oCirc As AcadCircle
    Dim oArc As AcadArc
    Dim oEll As AcadEllipse
    Dim oPline As AcadLWPolyline
    Dim oHatch As AcadHatch
    Dim oSpline As AcadSpline
    Dim oReg As AcadRegion
    Dim oPoint As AcadPoint
    Dim oBref As AcadBlockReference
    Dim oMt As AcadMText
    Dim oLeader As AcadLeader
    Dim Atts, Att
    Dim p1, p2, p3
    Dim MIN, MAX
    Dim ins, Cen
    Dim El(2) As Double
    Dim i As Integer
    Dim oFace As Acad3DFace
    Dim bLocked As Boolean
    Dim oLayer As AcadLayer

    Set oLayer = ThisDrawing.Layers(Ent.Layer)
    If oLayer.Lock = True Then
        bLocked = True
        oLayer.Lock = False
    End If
    
   If TypeOf Ent Is AcadLine Then
       Set oLine = Ent
       oLine.Thickness = 0
       oLine.StartPoint = Z0(oLine.StartPoint)
       oLine.EndPoint = Z0(oLine.EndPoint)
       If oLine.Length = 0 Then oLine.Delete
   ElseIf TypeOf Ent Is AcadMLine Then
       Set oMline = Ent
       p1 = oMline.Coordinates
       'If P1(2) = P1(5) Then
           If p1(2) <> 0 Then
               El(2) = p1(2)
               oMline.Move El, Zero
           End If
       'End If

   ElseIf TypeOf Ent Is AcadCircle Then
       Set oCirc = Ent
       oCirc.Thickness = 0
       If n1(oCirc) Then
           oCirc.Center = Z0(oCirc.Center)
       End If
   ElseIf TypeOf Ent Is AcadArc Then
       Set oArc = Ent
       oArc.Thickness = 0
       If oArc.Center(2) <> 0 Then
            If isArcN(oArc) Then
                oArc.Thickness = 0
                If n1(oArc) Then
                    oArc.Center = Z0(oArc.Center)
                End If
            End If
       End If
   ElseIf TypeOf Ent Is AcadEllipse Then
       Set oEll = Ent
       If n1(oEll) Then
            Cen = oEll.Center
            If Cen(2) <> 0 Then
                oEll.Center = Z0(Cen)
            End If
       End If
   ElseIf TypeOf Ent Is AcadLWPolyline Then
       Set oPline = Ent
       oPline.Thickness = 0
       If n1(oPline) Then
           oPline.Elevation = 0
       End If
    ElseIf TypeOf Ent Is AcadPolyline Then
        Dim Pline2d As AcadPolyline
       Set Pline2d = Ent
       Pline2d.Thickness = 0
       If n1(Pline2d) Then
           Pline2d.Elevation = 0
       End If
   ElseIf TypeOf Ent Is AcadHatch Then
       Set oHatch = Ent
       If n1(oHatch) Then
           oHatch.Elevation = 0
       End If
   ElseIf TypeOf Ent Is AcadSpline Then
       Set oSpline = Ent
       If oSpline.IsPlanar Then
           p1 = oSpline.FitPoints
           If UBound(p1) < 5 Then
               p1 = oSpline.ControlPoints
           End If
           If p1(2) = p1(5) Then
               El(2) = p1(2)
               oSpline.Move El, Zero
           End If
       End If
   ElseIf TypeOf Ent Is Acad3DPolyline Then
      Flatten3DPoly Ent
   ElseIf TypeOf Ent Is AcadRegion Then
       Set oReg = Ent
       If n1(oReg) Then
           Ent.GetBoundingBox MIN, MAX
           If Rd(MIN(2), MAX(2)) Then
               MAX = MIN
               MAX(2) = 0
               Ent.Move MIN, MAX
           End If
       End If
  ElseIf TypeOf Ent Is AcadPoint Then
       Set oPoint = Ent
       oPoint.Coordinates = Z0(oPoint.Coordinates)
   ElseIf TypeOf Ent Is AcadBlockReference Then
       Set oBref = Ent
       ins = oBref.InsertionPoint
       If ins(2) <> 0 Then
            If n1(oBref) Then
                oBref.InsertionPoint = Z0(ins)
                If oBref.HasAttributes Then
                    Atts = oBref.GetAttributes
                    For Each Att In Atts
                        Att.InsertionPoint = Z0(Att.InsertionPoint)
                        'Att.TextAlignmentPoint = Z0(Att.TextAlignmentPoint)
                    Next
                End If
            End If
       End If
    ElseIf TypeOf Ent Is AcadRasterImage Then
        Dim oImage As AcadRasterImage
        Set oImage = Ent
        If oImage.Origin(2) <> 0 Then
            p1 = oImage.Origin
            p1(2) = 0
            oImage.Origin = p1
        End If
   ElseIf TypeOf Ent Is AcadMText Or TypeOf Ent Is AcadText Then
        Dim Rot As Double
        Rot = Ent.Rotation
        If n1(Ent) Then
           If Ent.TextString = "" Then
               Ent.Delete
           Else
               ins = Ent.InsertionPoint
               If Not ins(2) = 0 Then
                   'If Rot <> 0 Then
                    Ent.InsertionPoint = Z0(ins)
                   'End If
               End If
               Ent.Rotation = Rot
           End If
       End If
   ElseIf TypeOf Ent Is AcadLeader Then
       Set oLeader = Ent
       p1 = oLeader.Normal
       If n1(oLeader) Then
           El(2) = oLeader.Coordinate(0)(2)
           oLeader.Move El, Zero
       End If
   ElseIf TypeOf Ent Is Acad3DFace Then
       Set oFace = Ent
       p1 = oFace.Coordinates
       For i = 0 To (UBound(p1) - 2) / 3
           p2 = oFace.Coordinate(i)
           p2(2) = 0
           oFace.Coordinate(i) = p2
       Next
   ElseIf TypeOf Ent Is AcadDimension Then

   'DimPointsToZero Ent
   End If

oLayer.Lock = bLocked



End Sub

Function Z0(p1 As Variant) As Variant
    p1(2) = 0
    Z0 = p1
End Function


Function n1(Ent As AcadEntity) As Boolean

    Dim N As Variant, Norm(2) As Double
    Dim oSpace As AcadBlock
    Dim oArc As AcadArc
    Dim newArc As AcadArc
    Dim newEll As AcadEllipse
    Dim oEll As AcadEllipse
    Dim oReg As AcadRegion
    Dim p1, p2
    Dim Sr As Double, Er As Double
    Dim Cen, M1
    
    'On Error GoTo Err_Control
    Norm(2) = 1
    N = Ent.Normal
    Dim oLayer As AcadLayer
    Set oLayer = ThisDrawing.Layers(Ent.Layer)
    If oLayer.Lock = True Then
        oLayer.Lock = False
    End If
    If Rd(N(0), 0) Then
        If Rd(N(1), 0) Then
            If Rd(N(2), 1) Then
                n1 = True
                If TypeOf Ent Is AcadRegion Or _
                       TypeOf Ent Is AcadLeader Then
                Else
                    Ent.Normal = Norm
                End If
            ElseIf Rd(N(2), -1) Then
                If TypeOf Ent Is AcadCircle Then
                    Ent.Normal = Norm
                    n1 = True
                ElseIf TypeOf Ent Is AcadArc Then
                    Set oArc = Ent
                    p1 = oArc.StartPoint
                    p2 = oArc.EndPoint
                    oArc.Rotate3D p1, p2, Pi
                    oArc.Rotate MidPoint(p1, p2), Pi
                    n1 = True
                 ElseIf TypeOf Ent Is AcadEllipse Then
                    Set oEll = Ent
                    Cen = oEll.Center
                    M1 = oEll.MinorAxis
                    p1 = Cen: p2 = Cen
                    p1(0) = p1(0) + M1(0)
                    p1(1) = p1(1) + M1(1)
                    p1(2) = p1(2) + M1(2)
                    
                    p2(0) = p2(0) - M1(0)
                    p2(1) = p2(1) - M1(1)
                    p2(2) = p2(2) - M1(2)
                    oEll.Rotate3D p1, p2, Pi
                    n1 = True
                ElseIf TypeOf Ent Is AcadRegion Then
                    Set oReg = Ent
                    MoveByBB oReg
                ElseIf TypeOf Ent Is AcadLeader Then
                    MoveByBB Ent
                ElseIf TypeOf Ent Is AcadBlockReference Then
                    Dim NegNorm(2) As Double
                    NegNorm(2) = -1
                    Ent.Normal = NegNorm
                    MoveByBB Ent
                End If
                
            End If
        End If
    End If
Exit_Here:
    Exit Function
Err_Control:
    Select Case Err.Number
        Case -2145386371   'General modeling failure
        Debug.Print oEll.ObjectID
        Case Else
        'MsgBox Err.Description
        Debug.Print Err.Number, Err.Description
        Err.Clear
        Resume Exit_Here
    End Select
End Function



Function isArcN(oArc As AcadArc) As Boolean
    Dim N As Variant
    Dim newN(2) As Double
    N = oArc.Normal
    If Abs(N(0)) < 0.0001 Then
        If Abs(N(1)) < 0.0001 Then
            If N(2) > 0.9999 And Abs(N(2)) < 1.0001 Then
                isArcN = True
                newN(2) = 1
                oArc.Normal = newN
                Exit Function
            ElseIf N(2) < -0.9999 And Abs(N(2)) > -1.0001 Then
                isArcN = True
                newN(2) = -1
                oArc.Normal = newN
                Exit Function
            End If
        End If
    End If
End Function





Function MoveByBB(Ent As AcadEntity)
    Dim MIN, MAX
    On Error Resume Next
    Ent.GetBoundingBox MIN, MAX
    If Rd(MIN(2), MAX(2)) Then
        MAX = MIN
        MAX(2) = 0
        Ent.Move MIN, MAX
    End If

End Function



Function Flatten3DPoly(o3Dpline As Acad3DPolyline) As AcadLWPolyline
    
    Dim Coord As Variant
    Dim Coords
    Dim Ct As Integer, i As Integer
    Dim oPline As AcadLWPolyline
    Dim Pts() As Double
    Dim Space As AcadBlock

    Coords = o3Dpline.Coordinates
    Ct = (UBound(Coords) / 3) - 1
    Debug.Print Ct
    ReDim Pts((Ct * 2) + 1)
    For i = 0 To Ct
    Coord = o3Dpline.Coordinate(i)
    Pts(i * 2) = Coord(0)
    Pts((i * 2) + 1) = Coord(1)
    Next i
    
    Set Space = ThisDrawing.ObjectIdToObject(o3Dpline.OwnerID)
    Set oPline = Space.AddLightWeightPolyline(Pts)
    If o3Dpline.Closed = True Then
        oPline.Closed = True
    End If
    oPline.Layer = o3Dpline.Layer
    oPline.TrueColor = o3Dpline.TrueColor
    Set Flatten3DPoly = oPline
    o3Dpline.Delete

End Function



Function Rd(num1 As Variant, num2 As Variant) As Boolean
    Dim dRet As Double
    dRet = num1 - num2
    If Abs(dRet) < 0.00000001 Then Rd = True
End Function

Function MidPoint(p1, p2) As Variant
    Dim dMid(2) As Double
    dMid(0) = (p1(0) + p2(0)) / 2
    dMid(1) = (p1(1) + p2(1)) / 2
    dMid(2) = (p1(2) + p2(2)) / 2
    MidPoint = dMid
End Function