Curve.cls 的問題
我用Frank Oquendo的Curve.cls将方块沿折线均匀排列。我遇到的问题是检索折线的斜率(一阶导数)。
dblParameter = objCurve。GetParameterAtDistance(I * dblSpacing)
dbl rotation = obj curve。GetFirstDerivative(dbl parameter)'
当我运行代码时，Curve.cls的get first derivative方法返回空。我认为错误发生在。EvalLispExpression行或其后的行。
有人给我出主意了吗？
**** Hidden Message ***** GetFirstDerivative以变量数组的形式返回方向向量，而不是双精度角......因此，如果你的数据旋转是双精度的，它将失败。如果这不是问题，你能更详细地定义你的“崩溃”吗？ 当不需要Curve类时，尽量不要使用它。
通过一点错误控制，这应该可以让您到达那里
Option Explicit
Const pi As Double = 3.14159265358979
Sub DividePoly()
Dim Ent As AcadEntity
Dim oPline As AcadLWPolyline
Dim cnt As Integer, CCnt As Integer
Dim Dist As Double, Tan As Double
Dim dLength As Double
Dim div As Integer
Dim unitL As Double
Dim i As Integer, j As Integer, K As Integer
Dim C1, C2, p
Dim C(5) As Variant
Dim dBulge As Double, Ang As Double
Dim Total As Double
Dim CoordCol As New Collection
Dim Elev As Double
Dim bBlock As Boolean
Dim oBref As AcadBlockReference
Dim sBlock As String
Dim Util As AcadUtility
Set Util = ThisDrawing.Utility
'Set Ent = EntSel("Select a pline to divide:")
Util.GetEntity Ent, p, "Select a pline to divide:"
If TypeOf Ent Is AcadLWPolyline Then
Set oPline = Ent
Else
MsgBox ("Must be a pline.")
Exit Sub
End If
On Error Resume Next
Dim keywordList As String
keywordList = "Block"
Util.InitializeUserInput 128, keywordList
Dim Answer As String
div = Util.GetInteger(vbCr & "Enter the number of segments or : ")
If Err Then
If StrComp(Err.Description, "User input is a keyword", 1) = 0 Then
Err.Clear
Answer = ThisDrawing.Utility.GetInput
If Answer = "Block" Then
bBlock = True
sBlock = Util.GetString(False, "Enter name of block to insert:")
If sBlock = "" Then Exit Sub
Dim oBlock As AcadBlock
Set oBlock = ThisDrawing.Blocks(sBlock)
If Err.Description = "Key not found" Then
Exit Sub
Else
div = Util.GetInteger(vbCr & "Enter the number of segments :")
End If
Else: Exit Sub
End If
End If
End If
On Error GoTo 0
If Not div > 1 Then Exit Sub
unitL = oPline.Length / div
Elev = oPline.Elevation
cnt = (UBound(oPline.Coordinates) - 1) / 2
If oPline.Closed = True Then
CCnt = cnt + 1
Else
CCnt = cnt
End If
For i = 0 To CCnt - 1
C1 = oPline.Coordinate(i)
If i = cnt Then
C2 = oPline.Coordinate(0)
Else
C2 = oPline.Coordinate(i + 1)
End If
C(0) = C1: C(1) = C2
dLength = segLength(C1, C2)
C(5) = dLength
dBulge = oPline.GetBulge(i)
C(3) = dBulge
If dBulge0 Then
'converting bulge to angle in radiansang=Atn(dBulge) * 4
Ang = Atn(dBulge) * 2
dLength = Ang * dLength / Sin(Ang)
C(4) = dLength
End If
Total = Total + dLength
C(2) = Total
CoordCol.Add C
Next i
dLength = 0
K = 1
For i = 1 To div - 1
dLength = dLength + unitL
For j = K To CCnt
If CoordCol(j)(2) >= dLength Then
Exit For
End If
Next j
If j > 1 Then
K = j - 1
Dist = dLength - CoordCol(K)(2)
Else
K = j
Dist = dLength
End If
dBulge = CoordCol(j)(3)
If dBulge = 0 Then
p = PtonLine(CoordCol(j)(0), CoordCol(j)(1), Dist, Tan)
Else
p = PtonArc(CoordCol(j), Dist, Tan)
End If
p(2) = Elev
p = ThisDrawing.Utility.TranslateCoordinates(p, acOCS, acWorld, 0, oPline.Normal)
If bBlock Then
Set oBref = ThisDrawing.ModelSpace.InsertBlock(p, sBlock, 1, 1, 1, Tan)
Dim Zero(2) As Double
oBref.Normal = oPline.Normal
oBref.InsertionPoint = p
Else
ThisDrawing.ModelSpace.AddPoint p
End If
Next i
End Sub
Function PtonLine(C1 As Variant, C2 As Variant, Dist As Double, Ang As Double) As Variant
'X = X1 + distance / dLength * DX
Dim X As Double, Y As Double
Dim Dx As Double, dY As Double
Dim dLength As Double
Dim p(2) As Double
X = C1(0): Y = C1(1)
Dx = C2(0) - X: dY = C2(1) - Y
dLength = Dist / Sqr(Dx * Dx + dY * dY)
p(0) = X + (dLength * Dx)
p(1) = Y + (dLength * dY)
PtonLine = p
Ang = AngFromX(C1, C2)
End Function
Function segLength(C1 As Variant, C2 As Variant) As Double
Dim Dx As Double, dY As Double
Dx = C2(0) - C1(0): dY = C2(1) - C1(1)
segLength = Sqr(Dx * Dx + dY * dY)
End Function
Function ArcLength(C1 As Variant, C2 As Variant, SegmentLength As Double, dBulge As Double) As Double
Dim Ang As Double
Ang = Atn(dBulge) * 2 'converting bulge to angle in radiansang=Atn(dBulge) * 4
ArcLength = Ang * SegmentLength / Sin(Ang)
End Function
Function PtonArc(C As Variant, Dist As Double, Tan As Double) As Variant
'X = X1 + distance / dLength * DX
Dim dBulge As Double
Dim dLength As Double
Dim p(2) As Double
Dim Ang As Double, Ang2 As Double
Dim Seg As Double
Dim segAng As Double, AngToCen
Dim Rad As Double
Dim CenPt(1) As Double
Dim C1, C2
Dim PosNeg As Integer
C1 = C(0): C2 = C(1)
dBulge = C(3)
Seg = C(5)
Ang = Atn(dBulge) * 2 'converting bulge to angle in radians= Atn(dBulge) * 4
Rad = Abs(Seg / (2 * Sin(Ang)))
segAng = AngFromX(C1, C2)
If dBulge > 0 Then
PosNeg = 1
AngToCen = segAng + ((0.5 * pi) - Ang)
Else
PosNeg = -1
AngToCen = segAng - ((0.5 * pi) + Ang)
End If
CenPt(0) = C1(0) + Cos(AngToCen) * Rad
CenPt(1) = C1(1) + Sin(AngToCen) * Rad
If AngToCen0
p(0) = CenPt(0) + (Cos(Ang) * Rad)
p(1) = CenPt(1) + (Sin(Ang) * Rad)
PtonArc = p
End Function
Public Function AngFromX(P1, P2) As Double
'If Not PointCheck(p1, p2) Then Exit Function
Dim Dx As Double, dY As Double
Dim dAng As Double
dY = P2(1) - P1(1): Dx = P2(0) - P1(0)
If Rd(dY, 0) Then'Line is horizontal
If Rd(Dx, 0) Then Exit Function
If Dx > 0 Then
dAng = 0
Else
dAng = pi '180
End If
ElseIf Rd(Dx, 0) Then'Line is vertical
If dY > 0 Then
dAng = 0.5 * pi '90
Else
dAng = 1.5 * pi '270
End If
Else
dAng = Atn(dY / Dx)
If dAng 270
If Dx 270
dAng = pi + dAng '90->180
Else '270->360
dAng = 2 * pi + dAng
End If
Else
If Dx 270
dAng = pi + dAng
End If
End If
End If
AngFromX = dAng
End Function
Function Rd(num1 As Variant, num2 As Variant) As Boolean
If Abs(num1 - num2) < 0.00000001 Then Rd = True
End Function
在测试时，我发现acad divide命令在一个时髦的UCS(2008版)中是不正确的。我已经添加了一个图来显示它，要插入的块是“b”。我的代码也是这样做的，直到我在0，0，0处添加块，更改法线以匹配样条线，然后将其插入点更改为正确的位置 杰夫，这正是问题所在，谢谢你的提示。
Bryco，我一直在寻找避免Curve.cls，但不太确定该怎么做。感谢您的帮助！这个周末我可能会仔细看看它。
页:
[1]