Running the flatten sub will bring the poly to 0 elev. (The sub is in pretty good shape)
Now if you stretch a poly vertex the dim adjusts perfectly whereas if you move a vertex the dim moves down in elev.
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