反转弧的法线？？乐筑天下 - Powered by Discuz! Archiver

Bryco 发表于 2006-8-3 23:41:48

反转弧的法线？？

如果原始弧为0,0，-1，是否有人可以共享一些代码，将弧的法线反转为0.0,1
谢谢，戴夫

Bryco 发表于 2006-8-4 00:04:10

戴夫，我认为有3种观点认为，改变正常的生活方式是没有反应的。弧，区域，某物
你必须做一个新的，很烦人
请仔细阅读下面的代码
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)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 Rot0 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.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

Bryco 发表于 2006-8-4 07:12:11

嗨，Dave，也许这对你有帮助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

（我认为对于区域，此属性是只读模式）
<fatty~&039；J#039~

Bryco 发表于 2006-8-4 07:27:07

谢谢大家
几小时后我会试一试
戴夫

Bryco 发表于 2006-8-4 10:05:08

Bryco，
我无法让你使用代码。当我将Rd改为圆形时，它似乎已经通过了，但我也不得不删除-1行。弧保持不变
脂肪，
我能够完成同样的事情。当你这样做时，弧线将移动和漫游。我想保持它的外观和位置与原来的弧完全相同。谢谢

Bryco 发表于 2006-8-4 11:30:38

这似乎有效
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
对于没有样条线的区域，需要分解该区域，将直线和圆弧法线（2）设置为1，并将其连接回多段线，然后从多段线创建一个区域
我在代码中经常这样做，所以这不是问题。如果有人需要什么，请告诉我

Bryco 发表于 2006-8-4 13:25:06

嘿，戴夫，好点子，很有魅力；J#039~

Bryco 发表于 2006-8-4 17:24:49

好的解决方案Dave，I&#039；我要用它
刚刚看到你的另一篇帖子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 这对我来说很有效，但我&#039；我还在换你的。

页: [1]

乐筑天下's Archiver

反转弧的法线？？