cxf11991 发表于 2004-5-21 09:44:00

选取直线裁剪

有四条直线成井字放置


我现在先选取横放的两条直线放在objselectionset选择集里


在选取竖放的两条直线放在objselectionset1选择集里


请问这样选好了，怎么样得到四个相交的点，并把相交点之间的线段都剪切掉!


请写上求交,剪切代码,,或者哪里有相似的例子,谢谢

cxf11991 发表于 2004-5-22 12:39:00

为什么没有人发表一下啊!

efan2000 发表于 2004-5-22 14:13:00

Sub test()
       Dim objselectionset As AcadSelectionSet
       Set objselectionset = ThisDrawing.SelectionSets.Add("objselectionset")
       Dim entobj(0) As AcadEntity
       Set entobj(0) = ThisDrawing.ModelSpace(0)
       objselectionset.AddItems entobj
       Set entobj(0) = ThisDrawing.ModelSpace(1)
       objselectionset.AddItems entobj
       Dim objselectionset1 As AcadSelectionSet
       Set objselectionset1 = ThisDrawing.SelectionSets.Add("objselectionset1")
       Set entobj(0) = ThisDrawing.ModelSpace(2)
       objselectionset1.AddItems entobj
       Set entobj(0) = ThisDrawing.ModelSpace(3)
       objselectionset1.AddItems entobj
      
       Dim entobj1 As AcadEntity
       Dim entobj2 As AcadEntity
       Dim pt As Variant
       Dim lineobj As AcadLine
       ' 处理水平的直线
       For Each entobj1 In objselectionset
               For Each entobj2 In objselectionset1
                     Set lineobj = entobj1
                     pt = entobj1.IntersectWith(entobj2, acExtendNone)
                     If Sqr((pt(0) - lineobj.StartPoint(0)) ^ 2 + (pt(1) - lineobj.StartPoint(1)) ^ 2) _
                           < Sqr((pt(0) - lineobj.EndPoint(0)) ^ 2 + (pt(1) - lineobj.EndPoint(1)) ^ 2) Then
                               ThisDrawing.ModelSpace.AddLine lineobj.StartPoint, pt
                     Else
                               ThisDrawing.ModelSpace.AddLine pt, lineobj.EndPoint
                     End If
               Next
       Next
       ' 处理垂直的直线
       For Each entobj1 In objselectionset1
               For Each entobj2 In objselectionset
                     Set lineobj = entobj1
                     pt = entobj1.IntersectWith(entobj2, acExtendNone)
                     If Sqr((pt(0) - lineobj.StartPoint(0)) ^ 2 + (pt(1) - lineobj.StartPoint(1)) ^ 2) _
                           < Sqr((pt(0) - lineobj.EndPoint(0)) ^ 2 + (pt(1) - lineobj.EndPoint(1)) ^ 2) Then
                               ThisDrawing.ModelSpace.AddLine lineobj.StartPoint, pt
                     Else
                               ThisDrawing.ModelSpace.AddLine pt, lineobj.EndPoint
                     End If
               Next
       Next
       ' 删除直线
       For Each entobj1 In objselectionset
               entobj1.Delete
       Next
       For Each entobj1 In objselectionset1
               entobj1.Delete
       Next
End Sub

cxf11991 发表于 2004-5-22 18:04:00

谢谢

cxf11991 发表于 2004-5-23 10:51:00

谢谢斑竹,这个程序很好用!<BR>在有一个简单的问题，就是怎么显示中文字


用thisdrawing.modelspace.addtecxt(text,ptinsert)


text只能显示英文字符串，怎么才能显示中文


<P class=program>用这样的ThisDrawing.ActiveTextStyle.fontFile = _


<P class=program>" C:/Program Files/ACAD2000/Fonts/italic.shx"改吗？


<P class=program>还是用别的方法

riechie 发表于 2004-5-27 22:18:00

VBA]怎么用sendcommand来调用trim命令？？


我要用sendcommand来调用trim命令来剪切圆角外的相交直线！怎么用！！在VB 中！！

雪山飞狐_lzh 发表于 2004-5-27 22:23:00

<A href="http://bbs.mjtd.com/forum.php?mod=viewthread&tid=19664&extra=&page=2" target="_blank" >http://bbs.mjtd.com/forum.php?mod=viewthread&tid=19664&extra=&page=2</A>

riechie 发表于 2004-5-27 22:42:00

"_.fillet" &amp; vbCr &amp; "r" &amp; vbCr &amp; "1" &amp; vbCr &amp; "( 是这个吗？<IMG alt=发贴心情 border=0 src="http://www.vba.cn/bbs/skins/default/topicface/face1.gif">        <B></B><BR>Sub Test()<BR>Dim ss As AcadSelectionSet<BR>Set ss = ThisDrawing.ActiveSelectionSet<BR>ss.Clear<BR>ss.SelectOnScreen<BR>ThisDrawing.SendCommand "_.fillet" &amp; vbCr &amp; "r" &amp; vbCr &amp; "1" &amp; vbCr &amp; "(handent " &amp; Chr(34) &amp; ss(0).Handle &amp; Chr(34) &amp; ")" &amp; vbCr &amp; "(handent " &amp; Chr(34) &amp; ss(1).Handle &amp; Chr(34) &amp; ")" &amp; vbCr



End Sub<BR>


<BR><BR>"_.fillet" &amp; vbCr &amp; "r" &amp; vbCr &amp; "1" &amp; vbCr &amp; "这个中trim怎么用啊！我是不知道他的用法！有什么书可以参考！！！

雪山飞狐_lzh 发表于 2004-5-27 22:47:00

你敲个命令在命令行试试不就行了
页: [1]
查看完整版本: 选取直线裁剪