Dave I think there are 3 thinks that dont respond to changing the normal. Arc, region, something.
You have to make a new one, very annoying.
Please sift through the code below.
Sub FlattenThis(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 ins, Cen
Dim Zero(2) As Double, El(2) As Double
Dim i As Integer
Dim oFace As Acad3DFace
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
If oarc.center(2) <> 0 Then
If isN(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 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
Dim oP3d As Acad3DPolyline
Set oP3d = Ent
'yada
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 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
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
On Error GoTo Err_Control
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
ElseIf TypeOf Ent Is AcadArc Then
Set oarc = Ent
P1 = oarc.center
P1(2) = 0
Sr = Pi - oarc.endAngle
Er = Pi - oarc.startAngle
Set oSpace = ThisDrawing.ObjectIdToObject(Ent.OwnerID)
Set newArc = oSpace.AddArc(P1, oarc.radius, Sr, Er)
newArc.Layer = oarc.Layer
newArc.LineType = oarc.LineType
newArc.LinetypeScale = oarc.LinetypeScale
oarc.Delete
ElseIf TypeOf Ent Is AcadEllipse Then
Set oEll = Ent
P1 = oEll.center
P1(2) = 0
Sr = (2 * Pi) - oEll.endAngle
Er = (2 * Pi) - oEll.startAngle
Set oSpace = ThisDrawing.ObjectIdToObject(Ent.OwnerID)
P2 = oEll.MajorAxis
P2(2) = 0
Set newEll = oSpace.AddEllipse(P1, P2, oEll.RadiusRatio)
With newEll
.startAngle = Sr
.endAngle = Er
.Layer = oEll.Layer
.LineType = oEll.LineType
.LinetypeScale = oEll.LinetypeScale
.TrueColor = oEll.TrueColor
End With
oEll.Delete
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 isN(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
isN = True
NewN(2) = 1
oarc.Normal = NewN
Exit Function
ElseIf N(2) < -0.9999 And Abs(N(2)) > -1.0001 Then
isN = 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
Ent.GetBoundingBox Min, Max
If Rd(Min(2), Max(2)) Then
Max = Min
Max(2) = 0
Ent.Move Min, Max
End If
End Function