关于交点的问题

wuyunpeng888

重新生成

nibenqiangdy

哎,最终还是没有解决掉,难道明经里面这么多人没有一个人会吗?

sailorcwx

写了一段，还有bug，下班了，回去捣鼓捣鼓

2. Sub inserttxt()
3. '定义π
4. Const pi = 3.1415
5. '声明线变量
6. Dim obj As AcadEntity
7. '声明点坐标变量
8. Dim pt As Variant
9. '选择线
10. ThisDrawing.Utility.GetEntity obj, pt, vbNewLine + "选择要插入文字的线: "
11. '声明文字对象变量
12. Dim txt As AcadText
13. '添加文字对象
14. Set txt = ThisDrawing.ModelSpace.AddText("测试", pt, ThisDrawing.GetVariable("textsize"))
15. '声明文字对象左下角坐标变量及右上角坐标变量
16. Dim lpt As Variant
17. Dim rpt As Variant
18. '求文字对象左下角坐标及右上角坐标
19. txt.GetBoundingBox lpt, rpt
20. '声明文字宽度变量
21. Dim txtwidth As Double
22. '求文字宽度
23. txtwidth = Abs(lpt(0) - rpt(0))
24. '修改文字对齐方式为居中对齐
25. txt.Alignment = acAlignmentMiddleCenter
26. '文字归位
27. txt.TextAlignmentPoint = pt
28. '声明交点坐标数组变量
29. Dim ipt() As Double
30. '求文字和线的交点
31. ipt = txt.IntersectWith(obj, acExtendBoth)
32. '声明交点坐标变量
33. Dim pt1(0 To 2) As Double
34. Dim pt2(0 To 2) As Double
35. '求交点坐标
36. pt1(0) = ipt(0)
37. pt1(1) = ipt(1)
38. pt1(2) = ipt(2)
39. pt2(0) = ipt(3)
40. pt2(1) = ipt(4)
41. pt2(2) = ipt(5)
42. '声明角度变量
43. Dim ang As Double
44. '求角度
45. ang = ThisDrawing.Utility.AngleFromXAxis(pt1, pt2)
46. '修正角度
47. If pi * 0.5 < ang And ang <= pi * 1.5 Then ang = ang + pi
48. '修正文字角度
49. txt.Rotation = ang
50. '声明打断点坐标变量
51. Dim bpt1 As Variant
52. Dim bpt2 As Variant
53. '求打断点坐标
54. bpt1 = ThisDrawing.Utility.PolarPoint(pt, ang, txtwidth * 0.7)
55. bpt2 = ThisDrawing.Utility.PolarPoint(pt, ang + pi, txtwidth * 0.7)
56. '打断
57. ThisDrawing.SendCommand ( _
58. "(command " & _
59. Chr(34) & "break" & Chr(34) & _
60. "(handent " & _
61. Chr(34) & obj.Handle & Chr(34) & _
62. ")" & _
63. Chr(34) & "none" & Chr(34) & _
64. "(list " & bpt1(0) & " " & bpt1(1) & " " & bpt1(2) & ")" & _
65. Chr(34) & "none" & Chr(34) & _
66. "(list " & bpt2(0) & " " & bpt2(1) & " " & bpt2(2) & ")) " _
67. )
68. End Sub

Sub inserttxt() '定义π Const pi = 3.1415 '声明线变量 Dim obj As AcadEntity '声明点坐标变量 Dim pt As Variant '选择线 ThisDrawing.Utility.GetEntity obj, pt, vbNewLine + "选择要插入文字的线: " '声明文字对象变量 Dim txt As AcadText '添加文字对象 Set txt = ThisDrawing.ModelSpace.AddText("测试", pt, ThisDrawing.GetVariable("textsize")) '声明文字对象左下角坐标变量及右上角坐标变量 Dim lpt As Variant Dim rpt As Variant '求文字对象左下角坐标及右上角坐标 txt.GetBoundingBox lpt, rpt '声明文字宽度变量 Dim txtwidth As Double '求文字宽度 txtwidth = Abs(lpt(0) - rpt(0)) '修改文字对齐方式为居中对齐 txt.Alignment = acAlignmentMiddleCenter '文字归位 txt.TextAlignmentPoint = pt '声明交点坐标数组变量 Dim ipt() As Double '求文字和线的交点 ipt = txt.IntersectWith(obj, acExtendBoth) '声明交点坐标变量 Dim pt1(0 To 2) As Double Dim pt2(0 To 2) As Double '求交点坐标 pt1(0) = ipt(0) pt1(1) = ipt(1) pt1(2) = ipt(2) pt2(0) = ipt(3) pt2(1) = ipt(4) pt2(2) = ipt(5) '声明角度变量 Dim ang As Double '求角度 ang = ThisDrawing.Utility.AngleFromXAxis(pt1, pt2) '修正角度 If pi * 0.5 < ang And ang <= pi * 1.5 Then ang = ang + pi '修正文字角度 txt.Rotation = ang '声明打断点坐标变量 Dim bpt1 As Variant Dim bpt2 As Variant '求打断点坐标 bpt1 = ThisDrawing.Utility.PolarPoint(pt, ang, txtwidth * 0.7) bpt2 = ThisDrawing.Utility.PolarPoint(pt, ang + pi, txtwidth * 0.7) '打断 ThisDrawing.SendCommand ( _ "(command " & _ Chr(34) & "break" & Chr(34) & _ "(handent " & _ Chr(34) & obj.Handle & Chr(34) & _ ")" & _ Chr(34) & "none" & Chr(34) & _ "(list " & bpt1(0) & " " & bpt1(1) & " " & bpt1(2) & ")" & _ Chr(34) & "none" & Chr(34) & _ "(list " & bpt2(0) & " " & bpt2(1) & " " & bpt2(2) & ")) " _ ) End Sub

sailorcwx

换一种方式，测试一下

2. Sub inserttxt()
3. On Error Resume Next
4. '定义π
5. Const pi = 3.1415
6. '声明点坐标变量
7. Dim pt As Variant
8. '选择点
9. pt = ThisDrawing.Utility.GetPoint(, "选择要插入文字的线段: ")
10. '声明一个临时选择集
11. Dim sset As AcadSelectionSet
12. ThisDrawing.SelectionSets.Add ("temp")
13. Set sset = ThisDrawing.SelectionSets("temp")
14. '定义过滤器
15. Dim ft(0) As Integer
16. Dim fd(0) As Variant
17. ft(0) = 0
18. fd(0) = "*LINE"
19. '选择线
20. sset.SelectAtPoint pt, ft, fd
21. '有没有选到线
22. If sset.Count > 0 Then
23. '声明线变量
24. Dim obj As AcadEntity
25. '取得线
26. Set obj = sset.Item(0)
27. '声明文字对象变量
28. Dim txt As AcadText
29. '添加文字对象
30. Set txt = ThisDrawing.ModelSpace.AddText("测试", pt, ThisDrawing.GetVariable("textsize"))
31. '声明文字对象左下角坐标变量及右上角坐标变量
32. Dim lpt As Variant
33. Dim rpt As Variant
34. '求文字对象左下角坐标及右上角坐标
35. txt.GetBoundingBox lpt, rpt
36. '声明文字宽度变量
37. Dim txtwidth As Double
38. '求文字宽度
39. txtwidth = Abs(lpt(0) - rpt(0))
40. '修改文字对齐方式为居中对齐
41. txt.Alignment = acAlignmentMiddleCenter
42. '文字归位
43. txt.TextAlignmentPoint = pt
44. '声明交点坐标数组变量
45. Dim ipt() As Double
46. '求文字和线的交点
47. ipt = txt.IntersectWith(obj, acExtendBoth)
48. '声明交点坐标变量
49. Dim pt1(0 To 2) As Double
50. Dim pt2(0 To 2) As Double
51. '求交点坐标
52. pt1(0) = ipt(0)
53. pt1(1) = ipt(1)
54. pt1(2) = ipt(2)
55. pt2(0) = ipt(3)
56. pt2(1) = ipt(4)
57. pt2(2) = ipt(5)
58. '声明角度变量
59. Dim ang As Double
60. '求角度
61. ang = ThisDrawing.Utility.AngleFromXAxis(pt1, pt2)
62. '修正角度
63. If pi * 0.5 < ang And ang <= pi * 1.5 Then ang = ang + pi
64. '修正文字角度
65. txt.Rotation = ang
66. '声明打断点坐标变量
67. Dim bpt1 As Variant
68. Dim bpt2 As Variant
69. '求打断点坐标
70. bpt1 = ThisDrawing.Utility.PolarPoint(pt, ang, txtwidth * 0.7)
71. bpt2 = ThisDrawing.Utility.PolarPoint(pt, ang + pi, txtwidth * 0.7)
72. '打断
73. ThisDrawing.SendCommand ( _
74. "(command " & _
75. Chr(34) & "break" & Chr(34) & _
76. "(handent " & _
77. Chr(34) & obj.Handle & Chr(34) & _
78. ")" & _
79. Chr(34) & "none" & Chr(34) & _
80. "(list " & bpt1(0) & " " & bpt1(1) & " " & bpt1(2) & ")" & _
81. Chr(34) & "none" & Chr(34) & _
82. "(list " & bpt2(0) & " " & bpt2(1) & " " & bpt2(2) & ")) " _
83. )
84. End If
85. '删除临时选集
86. sset.Delete
87. End Sub

Sub inserttxt() On Error Resume Next '定义π Const pi = 3.1415 '声明点坐标变量 Dim pt As Variant '选择点 pt = ThisDrawing.Utility.GetPoint(, "选择要插入文字的线段: ") '声明一个临时选择集 Dim sset As AcadSelectionSet ThisDrawing.SelectionSets.Add ("temp") Set sset = ThisDrawing.SelectionSets("temp") '定义过滤器 Dim ft(0) As Integer Dim fd(0) As Variant ft(0) = 0 fd(0) = "*LINE" '选择线 sset.SelectAtPoint pt, ft, fd '有没有选到线 If sset.Count > 0 Then '声明线变量 Dim obj As AcadEntity '取得线 Set obj = sset.Item(0) '声明文字对象变量 Dim txt As AcadText '添加文字对象 Set txt = ThisDrawing.ModelSpace.AddText("测试", pt, ThisDrawing.GetVariable("textsize")) '声明文字对象左下角坐标变量及右上角坐标变量 Dim lpt As Variant Dim rpt As Variant '求文字对象左下角坐标及右上角坐标 txt.GetBoundingBox lpt, rpt '声明文字宽度变量 Dim txtwidth As Double '求文字宽度 txtwidth = Abs(lpt(0) - rpt(0)) '修改文字对齐方式为居中对齐 txt.Alignment = acAlignmentMiddleCenter '文字归位 txt.TextAlignmentPoint = pt '声明交点坐标数组变量 Dim ipt() As Double '求文字和线的交点 ipt = txt.IntersectWith(obj, acExtendBoth) '声明交点坐标变量 Dim pt1(0 To 2) As Double Dim pt2(0 To 2) As Double '求交点坐标 pt1(0) = ipt(0) pt1(1) = ipt(1) pt1(2) = ipt(2) pt2(0) = ipt(3) pt2(1) = ipt(4) pt2(2) = ipt(5) '声明角度变量 Dim ang As Double '求角度 ang = ThisDrawing.Utility.AngleFromXAxis(pt1, pt2) '修正角度 If pi * 0.5 < ang And ang <= pi * 1.5 Then ang = ang + pi '修正文字角度 txt.Rotation = ang '声明打断点坐标变量 Dim bpt1 As Variant Dim bpt2 As Variant '求打断点坐标 bpt1 = ThisDrawing.Utility.PolarPoint(pt, ang, txtwidth * 0.7) bpt2 = ThisDrawing.Utility.PolarPoint(pt, ang + pi, txtwidth * 0.7) '打断 ThisDrawing.SendCommand ( _ "(command " & _ Chr(34) & "break" & Chr(34) & _ "(handent " & _ Chr(34) & obj.Handle & Chr(34) & _ ")" & _ Chr(34) & "none" & Chr(34) & _ "(list " & bpt1(0) & " " & bpt1(1) & " " & bpt1(2) & ")" & _ Chr(34) & "none" & Chr(34) & _ "(list " & bpt2(0) & " " & bpt2(1) & " " & bpt2(2) & ")) " _ ) End If '删除临时选集 sset.Delete End Sub

sailorcwx

增加圆弧和圆支持

2. Sub inserttxt()
3. On Error Resume Next
4. '定义π
5. Const pi = 3.1415
6. '声明点坐标变量
7. Dim pt As Variant
8. '选择点
9. pt = ThisDrawing.Utility.GetPoint(, "选择要插入文字的线段: ")
10. '声明一个临时选择集
11. Dim sset As AcadSelectionSet
12. ThisDrawing.SelectionSets.Add ("temp")
13. Set sset = ThisDrawing.SelectionSets("temp")
14. '定义过滤器
15. Dim ft(0) As Integer
16. Dim fd(0) As Variant
17. ft(0) = 0
18. fd(0) = "*LINE,arc,circle"
19. '选择线
20. sset.SelectAtPoint pt, ft, fd
21. '有没有选到线
22. If sset.Count > 0 Then
23. '声明线变量
24. Dim obj As AcadEntity
25. '取得线
26. Set obj = sset.Item(0)
27. '声明文字对象变量
28. Dim txt As AcadText
29. '添加文字对象
30. Set txt = ThisDrawing.ModelSpace.AddText("测试", pt, ThisDrawing.GetVariable("textsize"))
31. '声明文字对象左下角坐标变量及右上角坐标变量
32. Dim lpt As Variant
33. Dim rpt As Variant
34. '求文字对象左下角坐标及右上角坐标
35. txt.GetBoundingBox lpt, rpt
36. '声明文字宽度变量
37. Dim txtwidth As Double
38. '求文字宽度
39. txtwidth = Abs(lpt(0) - rpt(0))
40. '修改文字对齐方式为居中对齐
41. txt.Alignment = acAlignmentMiddleCenter
42. '文字归位
43. txt.TextAlignmentPoint = pt
44. '声明交点坐标数组变量
45. Dim ipt() As Double
46. '求文字和线的交点
47. ipt = txt.IntersectWith(obj, acExtendBoth)
48. '声明交点坐标变量
49. Dim pt1(0 To 2) As Double
50. Dim pt2(0 To 2) As Double
51. '求交点坐标
52. pt1(0) = ipt(0)
53. pt1(1) = ipt(1)
54. pt1(2) = ipt(2)
55. pt2(0) = ipt(3)
56. pt2(1) = ipt(4)
57. pt2(2) = ipt(5)
58. '声明角度变量
59. Dim ang As Double
60. '求角度
61. ang = ThisDrawing.Utility.AngleFromXAxis(pt1, pt2)
62. '修正角度
63. If pi * 0.5 < ang And ang <= pi * 1.5 Then ang = ang + pi
64. '修正文字角度
65. txt.Rotation = ang
66. '声明打断点坐标变量
67. Dim bpt1 As Variant
68. Dim bpt2 As Variant
69. '求打断点坐标
70. bpt1 = ThisDrawing.Utility.PolarPoint(pt, ang, txtwidth * 0.7)
71. bpt2 = ThisDrawing.Utility.PolarPoint(pt, ang + pi, txtwidth * 0.7)
72. '打断
73. ThisDrawing.SendCommand ( _
74. "(command " & _
75. Chr(34) & "break" & Chr(34) & _
76. "(handent " & _
77. Chr(34) & obj.Handle & Chr(34) & _
78. ")" & _
79. Chr(34) & "none" & Chr(34) & _
80. "(list " & bpt1(0) & " " & bpt1(1) & " " & bpt1(2) & ")" & _
81. Chr(34) & "none" & Chr(34) & _
82. "(list " & bpt2(0) & " " & bpt2(1) & " " & bpt2(2) & ")) " _
83. )
84. End If
85. '删除临时选集
86. sset.Delete
87. End Sub

Sub inserttxt() On Error Resume Next '定义π Const pi = 3.1415 '声明点坐标变量 Dim pt As Variant '选择点 pt = ThisDrawing.Utility.GetPoint(, "选择要插入文字的线段: ") '声明一个临时选择集 Dim sset As AcadSelectionSet ThisDrawing.SelectionSets.Add ("temp") Set sset = ThisDrawing.SelectionSets("temp") '定义过滤器 Dim ft(0) As Integer Dim fd(0) As Variant ft(0) = 0 fd(0) = "*LINE,arc,circle" '选择线 sset.SelectAtPoint pt, ft, fd '有没有选到线 If sset.Count > 0 Then '声明线变量 Dim obj As AcadEntity '取得线 Set obj = sset.Item(0) '声明文字对象变量 Dim txt As AcadText '添加文字对象 Set txt = ThisDrawing.ModelSpace.AddText("测试", pt, ThisDrawing.GetVariable("textsize")) '声明文字对象左下角坐标变量及右上角坐标变量 Dim lpt As Variant Dim rpt As Variant '求文字对象左下角坐标及右上角坐标 txt.GetBoundingBox lpt, rpt '声明文字宽度变量 Dim txtwidth As Double '求文字宽度 txtwidth = Abs(lpt(0) - rpt(0)) '修改文字对齐方式为居中对齐 txt.Alignment = acAlignmentMiddleCenter '文字归位 txt.TextAlignmentPoint = pt '声明交点坐标数组变量 Dim ipt() As Double '求文字和线的交点 ipt = txt.IntersectWith(obj, acExtendBoth) '声明交点坐标变量 Dim pt1(0 To 2) As Double Dim pt2(0 To 2) As Double '求交点坐标 pt1(0) = ipt(0) pt1(1) = ipt(1) pt1(2) = ipt(2) pt2(0) = ipt(3) pt2(1) = ipt(4) pt2(2) = ipt(5) '声明角度变量 Dim ang As Double '求角度 ang = ThisDrawing.Utility.AngleFromXAxis(pt1, pt2) '修正角度 If pi * 0.5 < ang And ang <= pi * 1.5 Then ang = ang + pi '修正文字角度 txt.Rotation = ang '声明打断点坐标变量 Dim bpt1 As Variant Dim bpt2 As Variant '求打断点坐标 bpt1 = ThisDrawing.Utility.PolarPoint(pt, ang, txtwidth * 0.7) bpt2 = ThisDrawing.Utility.PolarPoint(pt, ang + pi, txtwidth * 0.7) '打断 ThisDrawing.SendCommand ( _ "(command " & _ Chr(34) & "break" & Chr(34) & _ "(handent " & _ Chr(34) & obj.Handle & Chr(34) & _ ")" & _ Chr(34) & "none" & Chr(34) & _ "(list " & bpt1(0) & " " & bpt1(1) & " " & bpt1(2) & ")" & _ Chr(34) & "none" & Chr(34) & _ "(list " & bpt2(0) & " " & bpt2(1) & " " & bpt2(2) & ")) " _ ) End If '删除临时选集 sset.Delete End Sub

qq229918602

请问你找到解决两组多段线求交点的程序吗？能共享吗？