反转弧的法线？？

DaveW · 发表于 2006-8-3 23:41:48

如果原始圆弧为0,0，-1，是否有人可以共享一些代码，将圆弧的法线反转到0,0,1 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 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.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
[/code]

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

嗨，戴夫。
也许这对你有帮助。

copy

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

（我认为对于region，此属性是只读模式）
~'J'~

Fatty · 发表于 2006-8-4 07:12:11

谢谢你们
戴夫

DaveW · 发表于 2006-8-4 07:27:07

布莱科，
我无法让你的代码工作。当我将 Rd 更改为 round 时，它似乎会通过，但我也必须删除 -1 行。弧线保持不变。
胖子，
我能够完成同样的事情。当您执行此操作时，弧线将移动并旋转。我想保持它看起来和位置与原始弧线完全相同。
谢谢

DaveW · 发表于 2006-8-4 10:05:08

这似乎有效。

copy

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，然后将其连接回折线，然后从折线创建一个区域。
我在我的代码中做了很多，所以这不是问题。如果有人需要一些东西，请告诉我。

DaveW · 发表于 2006-8-4 11:30:38

嘿，戴夫
说得好
很管用
~'J'~

Fatty · 发表于 2006-8-4 13:25:06

好办法，戴夫，我会用的
刚刚看到你的另一篇文章

copy

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

这对我很有用，但我仍在换你的。

反转弧的法线？？

发表回复

精选推荐