[vb]弧长自动标注程序

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


Public AcadUtil As Object
Public Mospace As Object
Public AcadDoc As Object
Dim acadApp As AcadApplication

Private 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.Update

Do 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 Variant

Leng = returnObj.ArcLength
Spnt = returnObj.StartPoint
Epnt = returnObj.EndPoint
Cpnt = returnObj.Center

’选择标注位置
Dim PentforDim As Variant

PentforDim = 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(, "AutoCAD.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