laoxie_198 发表于 2007-6-15 17:39:00

[原创]多义线随意加点

<table height="100%"><tbody><tr height="100%"><td valign="top"><font face="宋体,verdana,arial,helvetica"><a href="http://p4.xdcad.net/forum/showthread.php?postid=3239714#post3239714"><u><font color="#003300"><b>1</b>楼楼主说：</font></u></a>[原创]：多义线上加点<b></b></font>
                                </td><td valign="top" align="right" width="10%" nowarp=""><input class="btn" type="button" style="FONT-SIZE: 9pt; FONT-FAMILY: 宋体;"/><select class="FormSelect" name="myfont" style="FONT-SIZE: 9pt; VISIBILITY: visible; FONT-FAMILY: 宋体;">
                                                <option value="9pt">9pt</option>
                                                <option value="10pt">10pt</option>
                                                <option value="11pt">11pt</option>
                                                <option value="12pt">12pt</option>
                                                <option value="13pt">13pt</option>
                                                <option value="15pt">15pt</option></select>
                                </td></tr><tr><td colspan="2"><font id="text1" face="宋体,verdana, arial, helvetica" style="FONT-SIZE: 10pt;"><br/>用pedit给多义线加点，感觉好麻烦的，就作了一个添加点的。在添加的时候最好要用最近点捕作方式。<br/>Sub jfjd() '多义线上添加点<br/>Dim i, j As Integer<br/>Dim jd As Double<br/>On Error Resume Next<br/>Dim xzj As AcadSelectionSet<br/>Dim xxzb As Variant<br/>If Not IsNull(ThisDrawing.SelectionSets.Item("jf")) Then<br/>Set xzj = ThisDrawing.SelectionSets.Item("jf")<br/>xzj.Delete<br/>End If<br/>Set xzj = ThisDrawing.SelectionSets.Add("jf")<br/>xzj.SelectOnScreen<br/>xxzb = ThisDrawing.Utility.GetPoint(, vbCrLf &amp; "请指定添加点的位置")<br/>Dim tjdzb(0 To 1) As Double<br/>tjdzb(0) = xxzb(0)<br/>tjdzb(1) = xxzb(1)<br/>'xzj.Delete<br/>Dim st As AcadEntity<br/>For Each st In xzj<br/>'Set st = ThisDrawing.ModelSpace.Item(0)<br/>Dim ds As Double<br/>Dim zb As Variant<br/>Dim ang() As Double<br/>Dim qd, hd As Integer<br/>'MsgBox st.ObjectName<br/>Dim xzb(0 To 2) As Double<br/>Dim zzb As Variant '添加后的坐标<br/>Dim jzb(0 To 2) As Double<br/>Dim pline As AcadLine<br/>Dim ppline As AcadLWPolyline<br/>ds = (UBound(st.Coordinates) + 1) / 2 '求出总点数<br/>ReDim ang(ds) As Double<br/>ReDim zzb(ds * 2 + 1) As Double<br/>zb = st.Coordinates<br/>'xzb(0) = 815.081<br/>'xzb(1) = 1173.804<br/>'xzb(2) = 0<br/>For i = 1 To ds<br/>jzb(0) = zb(i * 2 - 2)<br/>jzb(1) = zb(i * 2 - 1)<br/>jzb(2) = 0<br/>Set pline = ThisDrawing.ModelSpace.AddLine(xxzb, jzb)<br/>ang(i) = pline.Angle<br/>pline.Delete<br/>Next<br/>For i = 1 To ds<br/>For j = i + 1 To ds<br/>jd = Abs(ang(i) - ang(j))<br/>If Round(jd, 5) = 3.14159 Then<br/>qd = i '前点<br/>hd = j '后点<br/>End If<br/>Next j<br/>Next i<br/>'MsgBox qd<br/>'plineObj.Coordinate(0) = coord<br/>st.AddVertex qd, tjdzb<br/>kzsj st, 20<br/>Next st<br/>End Sub</font>
                                </td></tr></tbody></table>

leer168 发表于 2007-6-17 20:20:00

顶 谢谢了

laoxie_198 发表于 2007-6-20 08:32:00

不足之处请大家指出

mycad 发表于 2007-6-30 21:27:00

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

tnt1095 发表于 2007-7-5 08:40:00

楼主，假设我是想要把点加在线上，而我鼠标点击时，点击到的坐标又不在线上呢，怎么办？所以最好还是加个捕捉的功能你看怎么样
页: [1]
查看完整版本: [原创]多义线随意加点