[VB]弧长自动标注

yfy2003

运用圆弧的4个属性,弧长、起点、中点、终点，通过改变3点法标注圆弧角度对象的TextOverride属性值，用
弧长值代替角度值来实现弧长的自动标注。

2. Public AcadUtil As Object
3. Public Mospace As Object
4. Public AcadDoc As Object
5. Dim acadApp As AcadApplicationPrivate Sub fcbz_Click()
6. Dim Arc As AcadArc
7. Dim BasePnt As Variant
8. Dim returnObj As AcadEntity
9. Err.Clear
10. On Error Resume Next'选择圆弧
11. AcadUtil.GetEntity returnObj, BasePnt, "选择需标注的圆弧:"
12. returnObj.color = acRed
13. returnObj.UpdateDo Until returnObj.ObjectName = "AcDbArc"       Err.Clear
14.       
15.        MsgBox "你选择的对象是:" & returnObj.EntityName & "请继续选择", , "圆弧标注"
16.        returnObj.coloc = rcByLayer
17.        returnObj.Update
18.       
19.        AcadUtil.GetEntity returnObj, BasePnt, "选择需标注的圆弧:"
20.        returnObj.color = acRed
21.        returnObj.Update
22. Loop'获取圆弧的属性
23. Dim Leng As Double
24. Dim Spnt As Variant
25. Dim Epet As Variant
26. Dim Cpnt As VariantLeng = returnObj.ArcLength
27. Spnt = returnObj.StartPoint
28. Epnt = returnObj.EndPoint
29. Cpnt = returnObj.Center'选择标注位置
30. Dim PentforDim As VariantPentforDim = AcadUtil.GetPoint(, "选择标注位置:")'对圆弧进行角度标注
31. Dim dimAng As AcadDim3PointAngular
32. Set dimAng = Mospace.AddDim3PointAngular(Cpnt, Spnt, Epnt, PentforDim)
33. dimAng.TextHeight = 2'更改角度标注的文字为弧长
34. dimAng.TextOverride = Format(Leng, "0.000")
35. returnObj.coloc = rcByLayer
36. returnObj.Update
37. Set acadApp = Nothing
38. Set aAcadDoc = Nothing
39. End Sub'连接cad
40. Private Sub Form_Load()
41. On Error Resume Next
42. Set acadApp = GetObject(, "AutoCAD.Application")
43. If Err Then
44.      Err.Clear
45.      Set acadApp = CreateObject("AutoCAD.Application")
46. End If
47. Set AcadDoc = acadApp.ActiveDocument
48. Set Mospace = AcadDoc.ModelSpace
49. Set AcadUtil = AcadDoc.Utility
50. acadApp.Visible = acTrue
51. End Sub  

Public AcadUtil As Object Public Mospace As Object Public AcadDoc As Object Dim acadApp As AcadApplicationPrivate Sub fcbz_Click() Dim Arc As AcadArc Dim BasePnt As Variant Dim returnObj As AcadEntity Err.Clear On Error Resume Next'选择圆弧 AcadUtil.GetEntity returnObj, BasePnt, "选择需标注的圆弧:" returnObj.color = acRed returnObj.UpdateDo Until returnObj.ObjectName = "AcDbArc"       Err.Clear               MsgBox "你选择的对象是:" & returnObj.EntityName & "请继续选择", , "圆弧标注"        returnObj.coloc = rcByLayer        returnObj.Update               AcadUtil.GetEntity returnObj, BasePnt, "选择需标注的圆弧:"        returnObj.color = acRed        returnObj.Update Loop'获取圆弧的属性 Dim Leng As Double Dim Spnt As Variant Dim Epet As Variant Dim Cpnt As VariantLeng = returnObj.ArcLength Spnt = returnObj.StartPoint Epnt = returnObj.EndPoint Cpnt = returnObj.Center'选择标注位置 Dim PentforDim As VariantPentforDim = AcadUtil.GetPoint(, "选择标注位置:")'对圆弧进行角度标注 Dim dimAng As AcadDim3PointAngular Set dimAng = Mospace.AddDim3PointAngular(Cpnt, Spnt, Epnt, PentforDim) dimAng.TextHeight = 2'更改角度标注的文字为弧长 dimAng.TextOverride = Format(Leng, "0.000") returnObj.coloc = rcByLayer returnObj.Update Set acadApp = Nothing Set aAcadDoc = Nothing End Sub'连接cad Private Sub Form_Load() On Error Resume Next Set acadApp = GetObject(, "<a href="http://bbs.mjtd.com/forum-41-1.html" target="_blank" class="relatedlink">AutoCAD</a>.Application") If Err Then      Err.Clear      Set acadApp = CreateObject("AutoCAD.Application") End If Set AcadDoc = acadApp.ActiveDocument Set Mospace = AcadDoc.ModelSpace Set AcadUtil = AcadDoc.Utility acadApp.Visible = acTrue End Sub  

houlinbo

是张帆的《VBA开发精彩实例里的吗》里的吗？

lzws03

能否教在下一下，这个程序经过怎么样的操作才能在CAD里应用？要不然您就直接发一个加载就能用的程序得了？


我的邮箱是


lzws03@163.com

fanqinwei

弧长标注的命令的什么呀

 

兰州人

AcadUtil.GetEntity returnObj, BasePnt, "选择需标注的圆弧:"

学习这段语句

xiaowen

很感谢楼主分享,学习学习.

lichenxui

vb看不懂啊

lichenxui

收下，谢谢分享

lichenxui

收下，谢谢分享

【KAIXIN】

好长的源码