TheSwamp
Code Red => VB(A) => Topic started by: DaveW on August 03, 2006, 11:41:48 PM
-
Does anyone have some code that they can share that will reverse the normal of an arc to 0,0,1, if the original arc is 0,0,-1?
Thanks,
Dave
-
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
-
Does anyone have some code that they can share that will reverse the normal of an arc to 0,0,1, if the original arc is 0,0,-1?
Thanks,
Dave
Hi Dave
Maybe this will help for you
Sub PutArcNormal()
Dim oArc As AcadEntity
Dim pickPnt As Variant
Dim norVec As Variant
Dim vecStr As String
ThisDrawing.Utility.GetEntity oArc, pickPnt, vbCr & "Select arc"
If TypeOf oArc Is AcadArc Then
norVec = oArc.Normal
vecStr = Replace(CStr(norVec(0)), ",", ".") & "," & _
Replace(CStr(norVec(1)), ",", ".") & "," & _
Replace(CStr(norVec(2)), ",", ".")
MsgBox "Current normal is: " & vecStr
norVec(0) = 0#: norVec(1) = 0#: norVec(2) = 1#:
oArc.Normal = norVec
oArc.Update
vecStr = Replace(CStr(norVec(0)), ",", ".") & "," & _
Replace(CStr(norVec(1)), ",", ".") & "," & _
Replace(CStr(norVec(2)), ",", ".")
MsgBox "Normal changed to: " & vecStr
Else
MsgBox "This is not an arc"
Exit Sub
End If
End Sub
(I think for region this property is read only mode)
Fatty
~'J'~
-
Thanks guys.
I will give it a shot in few hours.
Dave
-
Bryco,
I could not get you code to work. It seemed to run through when I changed Rd to round, but I had to remove the -1 line too. The arc remained unchanged.
Fatty,
I was able to accomplish the same thing. The arc will move and roate when you do this. I want to keep it looking and positioned exactly as the original arc.
Thanks
-
This seems to work.
Sub ReverseArcNormal()
Dim oArc As AcadArc
Dim ent As AcadEntity
Dim STPoint(0 To 2) As Double
Dim ENPoint(0 To 2) As Double
Dim rotateAngle As Double
Dim midpoint(0 To 2) As Double
rotateAngle = 180
rotateAngle = rotateAngle * 3.14159265358979 / 180#
For Each ent In thisdrawing.ModelSpace
If TypeOf ent Is AcadArc Then
Set oArc = ent
STPoint(0) = oArc.StartPoint(0)
STPoint(1) = oArc.StartPoint(1)
STPoint(2) = oArc.StartPoint(2)
ENPoint(0) = oArc.EndPoint(0)
ENPoint(1) = oArc.EndPoint(1)
ENPoint(2) = oArc.EndPoint(2)
oArc.Rotate3D STPoint, ENPoint, rotateAngle
midpoint(0) = (STPoint(0) + ENPoint(0)) / 2
midpoint(1) = (STPoint(1) + ENPoint(1)) / 2
midpoint(2) = (STPoint(2) + ENPoint(2)) / 2
oArc.Rotate midpoint, rotateAngle
End If
Next
End Sub
For a region that does not have splines you will need to explode the region, set the lines and arcs normals (2) to 1 and them join it back into a polyline and then create a region from the polyline.
I do that quite a bit in my code so it is no issue. If anyone needs something for that let me know.
-
Hey, Dave
Good point
Works like a charm
~'J'~
-
Good solution Dave, I'm gonna use that.
Just saw your other post
Sub d()
Dim ent As AcadEntity, v
ThisDrawing.Utility.GetEntity ent, v
FlattenThis ent
End Sub
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
This works for me but I'm still changing to yours.