选取直线裁剪

cxf11991

有四条直线成井字放置


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


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


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


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

cxf11991

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

efan2000

2. Sub test()
3.        Dim objselectionset As AcadSelectionSet
4.        Set objselectionset = ThisDrawing.SelectionSets.Add("objselectionset")
5.        Dim entobj(0) As AcadEntity
6.        Set entobj(0) = ThisDrawing.ModelSpace(0)
7.        objselectionset.AddItems entobj
8.        Set entobj(0) = ThisDrawing.ModelSpace(1)
9.        objselectionset.AddItems entobj
10.        Dim objselectionset1 As AcadSelectionSet
11.        Set objselectionset1 = ThisDrawing.SelectionSets.Add("objselectionset1")
12.        Set entobj(0) = ThisDrawing.ModelSpace(2)
13.        objselectionset1.AddItems entobj
14.        Set entobj(0) = ThisDrawing.ModelSpace(3)
15.        objselectionset1.AddItems entobj
16.       
17.        Dim entobj1 As AcadEntity
18.        Dim entobj2 As AcadEntity
19.        Dim pt As Variant
20.        Dim lineobj As AcadLine
21.        ' 处理水平的直线
22.        For Each entobj1 In objselectionset
23.                For Each entobj2 In objselectionset1
24.                        Set lineobj = entobj1
25.                        pt = entobj1.IntersectWith(entobj2, acExtendNone)
26.                        If Sqr((pt(0) - lineobj.StartPoint(0)) ^ 2 + (pt(1) - lineobj.StartPoint(1)) ^ 2) _
27.                            < Sqr((pt(0) - lineobj.EndPoint(0)) ^ 2 + (pt(1) - lineobj.EndPoint(1)) ^ 2) Then
28.                                ThisDrawing.ModelSpace.AddLine lineobj.StartPoint, pt
29.                        Else
30.                                ThisDrawing.ModelSpace.AddLine pt, lineobj.EndPoint
31.                        End If
32.                Next
33.        Next
34.        ' 处理垂直的直线
35.        For Each entobj1 In objselectionset1
36.                For Each entobj2 In objselectionset
37.                        Set lineobj = entobj1
38.                        pt = entobj1.IntersectWith(entobj2, acExtendNone)
39.                        If Sqr((pt(0) - lineobj.StartPoint(0)) ^ 2 + (pt(1) - lineobj.StartPoint(1)) ^ 2) _
40.                            < Sqr((pt(0) - lineobj.EndPoint(0)) ^ 2 + (pt(1) - lineobj.EndPoint(1)) ^ 2) Then
41.                                ThisDrawing.ModelSpace.AddLine lineobj.StartPoint, pt
42.                        Else
43.                                ThisDrawing.ModelSpace.AddLine pt, lineobj.EndPoint
44.                        End If
45.                Next
46.        Next
47.        ' 删除直线
48.        For Each entobj1 In objselectionset
49.                entobj1.Delete
50.        Next
51.        For Each entobj1 In objselectionset1
52.                entobj1.Delete
53.        Next
54. End Sub

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

谢谢

cxf11991

谢谢斑竹,这个程序很好用!
在有一个简单的问题，就是怎么显示中文字 用thisdrawing.modelspace.addtecxt(text,ptinsert) text只能显示英文字符串，怎么才能显示中文

用这样的ThisDrawing.ActiveTextStyle.fontFile = _

" C:/Program Files/ACAD2000/Fonts/italic.shx"改吗？

还是用别的方法

riechie

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


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

雪山飞狐_lzh

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=19664&extra=&page=2

riechie

"_.fillet" & vbCr & "r" & vbCr & "1" & vbCr & "( 是这个吗？
Sub Test()
Dim ss As AcadSelectionSet
Set ss = ThisDrawing.ActiveSelectionSet
ss.Clear
ss.SelectOnScreen
ThisDrawing.SendCommand "_.fillet" & vbCr & "r" & vbCr & "1" & vbCr & "(handent " & Chr(34) & ss(0).Handle & Chr(34) & ")" & vbCr & "(handent " & Chr(34) & ss(1).Handle & Chr(34) & ")" & vbCr End Sub


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

雪山飞狐_lzh

你敲个命令在命令行试试不就行了