[原创]多义线随意加点

laoxie_198

1楼楼主说：[原创]：多义线上加点

9pt 10pt 11pt 12pt 13pt 15pt

用pedit给多义线加点，感觉好麻烦的，就作了一个添加点的。在添加的时候最好要用最近点捕作方式。 Sub jfjd() '多义线上添加点 Dim i, j As Integer Dim jd As Double On Error Resume Next Dim xzj As AcadSelectionSet Dim xxzb As Variant If Not IsNull(ThisDrawing.SelectionSets.Item("jf")) Then Set xzj = ThisDrawing.SelectionSets.Item("jf") xzj.Delete End If Set xzj = ThisDrawing.SelectionSets.Add("jf") xzj.SelectOnScreen xxzb = ThisDrawing.Utility.GetPoint(, vbCrLf & "请指定添加点的位置") Dim tjdzb(0 To 1) As Double tjdzb(0) = xxzb(0) tjdzb(1) = xxzb(1) 'xzj.Delete Dim st As AcadEntity For Each st In xzj 'Set st = ThisDrawing.ModelSpace.Item(0) Dim ds As Double Dim zb As Variant Dim ang() As Double Dim qd, hd As Integer 'MsgBox st.ObjectName Dim xzb(0 To 2) As Double Dim zzb As Variant '添加后的坐标 Dim jzb(0 To 2) As Double Dim pline As AcadLine Dim ppline As AcadLWPolyline ds = (UBound(st.Coordinates) + 1) / 2 '求出总点数 ReDim ang(ds) As Double ReDim zzb(ds * 2 + 1) As Double zb = st.Coordinates 'xzb(0) = 815.081 'xzb(1) = 1173.804 'xzb(2) = 0 For i = 1 To ds jzb(0) = zb(i * 2 - 2) jzb(1) = zb(i * 2 - 1) jzb(2) = 0 Set pline = ThisDrawing.ModelSpace.AddLine(xxzb, jzb) ang(i) = pline.Angle pline.Delete Next For i = 1 To ds For j = i + 1 To ds jd = Abs(ang(i) - ang(j)) If Round(jd, 5) = 3.14159 Then qd = i '前点 hd = j '后点 End If Next j Next i 'MsgBox qd 'plineObj.Coordinate(0) = coord st.AddVertex qd, tjdzb kzsj st, 20 Next st End Sub

leer168

顶 谢谢了

laoxie_198

不足之处请大家指出

mycad

运行时提示kzsj模块或函数未定义

tnt1095

楼主，假设我是想要把点加在线上，而我鼠标点击时，点击到的坐标又不在线上呢，怎么办？所以最好还是加个捕捉的功能你看怎么样