将多边形各边边长注记在各边中点上源代码（VBA）

topirol

不足之处，请完善

2. Const pi = 3.1415926
   
3. Sub add_dis_to_midp()
   
4. Dim entry As Object
   
5. Dim pickedp As Variant
   
6. Dim pickedp1 As Variant
   
7. Dim coors As Variant
   
8. Dim vexn As Integer
   
9. Dim i As Integer
   
10. Dim midtext As AcadText
    
11. Dim textstr As String
    
12. Dim ang As Double
    
13. Dim Ispoly As Boolean
    
14. Ispoly = False
    
15. On Error Resume Next
    
16. Dim textheight1 As Double
    
17. 
    
18. textheight1 = 1#  '定义字高
    
19. Dim offsetvalue As Double
    
20. offsetvalue = 0.5 '定义文字偏移直线的距离
    
21. 
    
22. Dim inserttext(0 To 2) As Double
    
23. ThisDrawing.Utility.GetEntity entry, pickedp, "选择一个多边形:"
    
24. '获得顶点数
    
25. If TypeName(entry) = "IAcadLWPolyline" Then
    
26.     vexn = (UBound(entry.Coordinates) + 1) / 2
    
27.     Ispoly = True
    
28. End If
    
29. If TypeName(entry) = "IAcadPolyline" Then
    
30.     vexn = (UBound(entry.Coordinates) + 1) / 3
    
31.     Ispoly = True
    
32. End If
    
33. 
    
34. If Ispoly Then
    
35.     For i = 0 To vexn - 1 Step 1
    
36.         pickedp = entry.Coordinate(i)
    
37.         If i = vexn - 1 And entry.Closed = True Then
    
38.         pickedp1 = entry.Coordinate(0)
    
39.         Else
    
40.         pickedp1 = entry.Coordinate(i + 1)
    
41.         End If
    
42.         '线段中点
    
43.         inserttext(0) = (pickedp(0) + pickedp1(0)) / 2
    
44.         inserttext(1) = (pickedp(1) + pickedp1(1)) / 2
    
45.         inserttext(2) = 0
    
46.         
    
47.         '线段距离
    
48.         textstr = CStr(dist(pickedp, pickedp1))
    
49.         '文字角度
    
50.         'ang = ThisDrawing.Utility.AngleFromXAxis(pickedp, pickedp1)
    
51.         ang = getang(pickedp, pickedp1) '+ pi   加pi表示文字在前进反向的右边，不加是左边
    
52.         '偏移处理
    
53.         pickedp = ThisDrawing.Utility.PolarPoint(inserttext, ang + pi / 2, offsetvalue)
    
54.         
    
55.         inserttext(0) = pickedp(0)
    
56.         inserttext(1) = pickedp(1)
    
57.         inserttext(2) = 0
    
58.         '写文字
    
59.         If textstr <> "0" Then '0距离不处理
    
60.         Set midtext = ThisDrawing.ModelSpace.AddText(textstr, inserttext, textheight1)
    
61.         
    
62.         midtext.Alignment = acAlignmentCenter
    
63.         midtext.TextAlignmentPoint = inserttext
    
64.         midtext.Rotation = ang
    
65.         End If
    
66.     Next
    
67. End If
    
68. End Sub
    
69. 
    
70. Function dist(p1 As Variant, p2 As Variant) As Double '距离
    
71. On Error Resume Next
    
72. dist = Sqr(((p1(0) - p2(0)) ^ 2 + (p1(1) - p2(1)) ^ 2))
    
73. If Err Then
    
74. Err.Clear
    
75. dist = 0
    
76. End If
    
77. End Function
    
78. 
    
79. 
    
80. Function getang(p1 As Variant, p2 As Variant) '角度
    
81. On Error Resume Next
    
82. Dim pl As AcadLine
    
83. Dim startp(0 To 2) As Double
    
84. Dim endp(0 To 2) As Double
    
85. startp(0) = p1(0)
    
86. startp(1) = p1(1)
    
87. startp(2) = 0
    
88. endp(0) = p2(0)
    
89. endp(1) = p2(1)
    
90. endp(2) = 0
    
91. Set pl = ThisDrawing.ModelSpace.AddLine(startp, endp)
    
92. getang = pl.Angle
    
93. pl.Delete
    
94. End Function
    
95. 
    

Const pi = 3.1415926<br /> Sub add_dis_to_midp()<br /> Dim entry As Object<br /> Dim pickedp As Variant<br /> Dim pickedp1 As Variant<br /> Dim coors As Variant<br /> Dim vexn As Integer<br /> Dim i As Integer<br /> Dim midtext As AcadText<br /> Dim textstr As String<br /> Dim ang As Double<br /> Dim Ispoly As Boolean<br /> Ispoly = False<br /> On Error Resume Next<br /> Dim textheight1 As Double<br /> <br /> textheight1 = 1#  '定义字高<br /> Dim offsetvalue As Double<br /> offsetvalue = 0.5 '定义文字偏移直线的距离<br /> <br /> Dim inserttext(0 To 2) As Double<br /> ThisDrawing.Utility.GetEntity entry, pickedp, "选择一个多边形:"<br /> '获得顶点数<br /> If TypeName(entry) = "IAcadLWPolyline" Then<br />     vexn = (UBound(entry.Coordinates) + 1) / 2<br />     Ispoly = True<br /> End If<br /> If TypeName(entry) = "IAcadPolyline" Then<br />     vexn = (UBound(entry.Coordinates) + 1) / 3<br />     Ispoly = True<br /> End If<br /> <br /> If Ispoly Then<br />     For i = 0 To vexn - 1 Step 1<br />         pickedp = entry.Coordinate(i)<br />         If i = vexn - 1 And entry.Closed = True Then<br />         pickedp1 = entry.Coordinate(0)<br />         Else<br />         pickedp1 = entry.Coordinate(i + 1)<br />         End If<br />         '线段中点<br />         inserttext(0) = (pickedp(0) + pickedp1(0)) / 2<br />         inserttext(1) = (pickedp(1) + pickedp1(1)) / 2<br />         inserttext(2) = 0<br />         <br />         '线段距离<br />         textstr = CStr(dist(pickedp, pickedp1))<br />         '文字角度<br />         'ang = ThisDrawing.Utility.AngleFromXAxis(pickedp, pickedp1)<br />         ang = getang(pickedp, pickedp1) '+ pi   加pi表示文字在前进反向的右边，不加是左边<br />         '偏移处理<br />         pickedp = ThisDrawing.Utility.PolarPoint(inserttext, ang + pi / 2, offsetvalue)<br />         <br />         inserttext(0) = pickedp(0)<br />         inserttext(1) = pickedp(1)<br />         inserttext(2) = 0<br />         '写文字<br />         If textstr <> "0" Then '0距离不处理<br />         Set midtext = ThisDrawing.ModelSpace.AddText(textstr, inserttext, textheight1)<br />         <br />         midtext.Alignment = acAlignmentCenter<br />         midtext.TextAlignmentPoint = inserttext<br />         midtext.Rotation = ang<br />         End If<br />     Next<br /> End If<br /> End Sub<br /> <br /> Function dist(p1 As Variant, p2 As Variant) As Double '距离<br /> On Error Resume Next<br /> dist = Sqr(((p1(0) - p2(0)) ^ 2 + (p1(1) - p2(1)) ^ 2))<br /> If Err Then<br /> Err.Clear<br /> dist = 0<br /> End If<br /> End Function<br /> <br /> <br /> Function getang(p1 As Variant, p2 As Variant) '角度<br /> On Error Resume Next<br /> Dim pl As AcadLine<br /> Dim startp(0 To 2) As Double<br /> Dim endp(0 To 2) As Double<br /> startp(0) = p1(0)<br /> startp(1) = p1(1)<br /> startp(2) = 0<br /> endp(0) = p2(0)<br /> endp(1) = p2(1)<br /> endp(2) = 0<br /> Set pl = ThisDrawing.ModelSpace.AddLine(startp, endp)<br /> getang = pl.Angle<br /> pl.Delete<br /> End Function<br /> <br />

mccad

计算角度可以用AngleFromXAxis 方法
标注的文字最好按照当前标注样式的大小和小数点位数来标注，并注意文字的旋转角度。

topirol

ang = ThisDrawing.Utility.AngleFromXAxis(pickedp, pickedp1) + pi
跟ang = getang(pickedp, pickedp1) + pi

运行的结果不同，何解？

h_lon

谢谢各位老大帮了我大忙！

mccad

可能是因为AngleFromXAxis方法需要三维点，而二维多段线的顶点是二维点。