wuyunpeng888 发表于 2008-8-30 00:06:00

重新生成

nibenqiangdy 发表于 2008-9-4 15:06:00

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

sailorcwx 发表于 2008-9-4 17:37:00

本帖最后由 作者 于 2008-9-4 17:57:18 编辑

写了一段，还有bug，下班了，回去捣鼓捣鼓
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 发表于 2008-9-4 18:25:00

换一种方式，测试一下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 发表于 2008-9-4 18:31:00

增加圆弧和圆支持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 发表于 2012-5-8 23:02:55

请问你找到解决两组多段线求交点的程序吗？能共享吗？
页: 1 [2]
查看完整版本: 关于交点的问题