[VB]弧长自动标注
本帖最后由 作者 于 2004-9-13 20:05:32 编辑运用圆弧的4个属性,弧长、起点、中点、终点，通过改变3点法标注圆弧角度对象的TextOverride属性值，用
弧长值代替角度值来实现弧长的自动标注。 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(, "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 是张帆的《VBA开发精彩实例里的吗》里的吗？ 能否教在下一下，这个程序经过怎么样的操作才能在CAD里应用？要不然您就直接发一个加载就能用的程序得了？
我的邮箱是
lzws03@163.com <P>弧长标注的命令的什么呀</P>
<P> </P> <p>AcadUtil.<font color="#0000ff">GetEntity</font> returnObj, BasePnt, <font color="#880000">"选择需标注的圆弧:"</font></p><p><font color="#880000">学习这段语句</font></p> <p>很感谢楼主分享,学习学习.</p> vb看不懂啊 收下，谢谢分享 收下，谢谢分享 好长的源码
页:
[1]