零海拔。

Sub Flatten()
    Dim Ent As AcadEntity
    Dim obj 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 Zero(2) As Double, El(2) As Double
    
    For Each Ent In ThisDrawing.ModelSpace
        If TypeOf Ent Is AcadLine Then
            Set oLine = Ent
            oLine.StartPoint = Z0(oLine.StartPoint)
            oLine.EndPoint = Z0(oLine.EndPoint)
            If oLine.Length = 0 Then oLine.Delete
        End If
        If TypeOf Ent Is AcadMLine Then
            Set oMline = Ent
            P1 = oMline.Coordinates
            If P1(2) = P1(5) Then
                El(2) = P1(2)
                oMline.Move El, Zero
            End If
    
        End If
        
        If TypeOf Ent Is AcadCircle Then
            Set oCirc = Ent
            If N1(oCirc) Then
                oCirc.Center = Z0(oCirc.Center)
            End If
        End If
        If TypeOf Ent Is AcadArc Then
            Set oArc = Ent
            If N1(oArc) Then
                oArc.Center = Z0(oArc.Center)
            End If
        End If
        If TypeOf Ent Is AcadEllipse Then
            Set oEll = Ent
            If N1(oEll) Then
                oEll.Center = Z0(oEll.Center)
            End If
        End If
        If TypeOf Ent Is AcadLWPolyline Then
            Set oPline = Ent
            If N1(oPline) Then
                oPline.Elevation = 0
            End If
        End If
        If TypeOf Ent Is AcadHatch Then
            Set oHatch = Ent
            If N1(oHatch) Then
                oHatch.Elevation = 0
            End If
        End If
        If TypeOf Ent Is AcadSpline Then
            Set oSpline = Ent
            If oSpline.IsPlanar Then
                P1 = oSpline.FitPoints
                If P1(2) = P1(5) Then
                    El(2) = P1(2)
                    oSpline.Move El, Zero
                End If
            End If
        End If
        If TypeOf Ent Is Acad3DPolyline Then
            Dim oP3 As Acad3DPolyline
            'yada
        End If
        If 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
        End If
        If TypeOf Ent Is AcadPoint Then
            Set oPoint = Ent
            oPoint.Coordinates = Z0(oPoint.Coordinates)
        End If
        If TypeOf Ent Is AcadBlockReference Then
            Set oBref = Ent
            If N1(oBref) Then
                oBref.InsertionPoint = Z0(oBref.InsertionPoint)
                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
        If TypeOf Ent Is AcadMText Or TypeOf Ent Is AcadText Then
            If N1(Ent) Then
                Ent.InsertionPoint = Z0(Ent.InsertionPoint)
            End If
        End If
        If 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
        End If
        If TypeOf Ent Is AcadDimension Then
     
        
        End If
    Next
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
    Norm(2) = 1
    n = Ent.Normal
    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
                End If
            End If
        End If
    End If
End Function
Function MoveByBB(Ent As AcadEntity)
    Dim Min, Max
    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 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

Sub DimPointsToZero()
    Dim StartPoint As Variant
    Dim EndPoint As Variant
    Dim DimLinePoint As Variant
    Dim DimBlock As AcadBlock
    Dim sName As String
    Dim Ent As AcadEntity
    Dim oPoint As AcadPoint
    Dim oDim As AcadDimension
    Dim i As Integer, j As Integer
    Set oDim = EntSel
    sName = vbAssoc(oDim, 2)
    Set DimBlock = ThisDrawing.Blocks(sName)
    For i = 0 To DimBlock.Count - 1
        Set Ent = DimBlock(i)
        If TypeOf Ent Is AcadPoint Then
            Set oPoint = Ent
            Select Case j
                Case 0
                    StartPoint = oPoint.Coordinates
                    StartPoint(2) = 0
                    oPoint.Coordinates = StartPoint
                Case 1
                    EndPoint = oPoint.Coordinates
                    EndPoint(2) = 0
                    oPoint.Coordinates = EndPoint
                Case 2
                    DimLinePoint = oPoint.Coordinates
                    DimLinePoint(2) = 0
                     oPoint.Coordinates = DimLinePoint
            End Select
            j = j + 1
            oPoint.Update
        End If
    Next i
Debug.Print oDim.Rotation
Debug.Print vbAssoc(oDim, 50)
Dim newDim As AcadDimension
Dim Cs As AcadBlock
Set Cs = CurrentSpace
Dim xT, xV
oDim.GetXData "", xT, xV
Set newDim = Cs.AddDimRotated(StartPoint, EndPoint, DimLinePoint, vbAssoc(oDim, 50))
newDim.Layer = oDim.Layer
newDim.TrueColor = oDim.TrueColor
If Not IsEmpty(xV) Then
    newDim.SetXData xT, xV
End If
newDim.StyleName = oDim.StyleName
oDim.Delete
End Sub