[原创]多义线随意加点
[原创]：多义线上加点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
**** Hidden Message ***** 顶 谢谢了 不足之处请大家指出 运行时提示kzsj模块或函数未定义 楼主，假设我是想要把点加在线上，而我鼠标点击时，点击到的坐标又不在线上呢，怎么办？所以最好还是加个捕捉的功能你看怎么样
页:
[1]