[例程]使用尺寸--半径直径
Public Sub UseRadial()ThisDrawing.ActiveTextStyle.fontFile = CurDir() & "\fonts\txt.shx"
Dim entObj As AcadEntity '用于选择图元对象
Dim dimObj As AcadDimRadial '用于创建半径标注
Dim center As Variant '用于设定圆心坐标
Dim chordPoint(0 To 2) As Double '用于设定标注点
Dim pickPoint As Variant '选择图元对象时的拾取点
Dim leaderLen As Double '设定引线的长度
'在模型空间选择要标注的圆弧或圆
ThisDrawing.Utility.GetEntity entObj, pickPoint
If StrComp(entObj.ObjectName, "AcDbArc", 1) = 0 Or _
StrComp(entObj.ObjectName, "AcDbCircle", 1) = 0 Then
'获取圆弧或圆的圆心坐标
center = entObj.center
Else
'如果选择的不是圆弧或圆则退出程序
MsgBox "选择的图元类型不对！"
Exit Sub
End If
'将图元选择拾取点和圆心点的连线与圆弧或圆的交点作为标注点
Dim lineObj As AcadLine
Dim insectPoint As Variant
'在拾取点与圆心之间创建临时连线
Set lineObj = ThisDrawing.ModelSpace.AddLine(pickPoint, entObj.center)
lineObj.Visible = False
'求出临时连线与圆弧或原的交点
insectPoint = lineObj.IntersectWith(entObj, acExtendThisEntity)
lineObj.Delete '删除临时连线
'如果是圆可能有2个交点，指定哪个交点做标注点
chordPoint(0) = insectPoint(0)
chordPoint(1) = insectPoint(1)
chordPoint(2) = insectPoint(2)
'设定引线的长度，该参数可以省略
leaderLen = ThisDrawing.Utility.GetDistance(chordPoint, "确定引线长度：")
'在模型空间创建半径尺寸标注
Set dimObj = ThisDrawing.ModelSpace. _
AddDimRadial(center, chordPoint, leaderLen)
'ZoomAll
dimObj.UnitsFormat = acDimLDecimal
dimObj.DecimalSeparator = "."
dimObj.ArrowheadSize = 5
dimObj.TextHeight = 6
dimObj.TextGap = 3
'dimObj.ForceLineInside = False
'dimObj.FractionFormat = acNotStacked
dimObj.Fit = acTextAndArrows
'dimObj.TextOutsideAlign = True
dimObj.TextInsideAlign = True
'dimObj.DimLineSuppress = True
'dimObj.ExtensionLineOffset = 20 'Not suported
'dimObj.HorizontalTextPosition = acFirstExtensionLine
'dimObj.VerticalTextPosition = acVertCentered
'dimObj.CenterType = acCenterMark
'dimObj.CenterMarkSize = 5
'Dim radStr As String
'MsgBox "Radius = " & entObj.Radius
'radStr = "R" & CStr(entObj.Radius)
'dimObj.TextOverride = radStr
'ThisDrawing.Regen acActiveViewport
'MsgBox "标注文字的旋转角：" & dimObj.TextRotation
End Sub
Public Sub IdentifyDimType()
Dim dimObj As AcadEntity
Dim pickPnt As Variant
Dim center As Variant
ThisDrawing.Utility.GetEntity dimObj, pickPnt
center = dimObj.center
MsgBox "该尺寸的对象名为：" & dimObj.ObjectName
MsgBox "中心坐标为：" & center(0)
End Sub
Public Sub UseDimDiameter()
ThisDrawing.ActiveTextStyle.fontFile = CurDir() & "\fonts\txt.shx"
'ThisDrawing.ActiveTextStyle.fontFile = "c:\windows\fonts\simsun.ttf"
Dim entObj As AcadEntity
Dim dimObj As AcadDimDiametric
Dim center As Variant
Dim pickPoint As Variant
Dim chordPoint(0 To 2) As Double
Dim FarchordPoint(0 To 2) As Double
Dim insectPoint As Variant
Dim leaderLen As Double
'在模型空间选择要标注的圆
ThisDrawing.Utility.GetEntity entObj, pickPoint
If StrComp(entObj.ObjectName, "AcDbArc", 1) = 0 Or _
StrComp(entObj.ObjectName, "AcDbCircle", 1) = 0 Then
'获取圆的圆心坐标
center = entObj.center
Else
'如果选择的不是圆则退出程序
MsgBox "选择的图元类型不对！"
Exit Sub
End If
'在拾取点与圆心之间创建临时连线
Dim lineObj As AcadLine
Set lineObj = ThisDrawing.ModelSpace.AddLine(entObj.center, pickPoint)
lineObj.Visible = False
'求出临时连线与圆的交点
insectPoint = lineObj.IntersectWith(entObj, acExtendBoth)
lineObj.Delete
'将第1个交点做为标注点
chordPoint(0) = insectPoint(0)
chordPoint(1) = insectPoint(1)
chordPoint(2) = insectPoint(2)
'将第2个交点做为远标注点
FarchordPoint(0) = insectPoint(3)
FarchordPoint(1) = insectPoint(4)
FarchordPoint(2) = insectPoint(5)
'设定引线的长度，该参数可以省略
'leaderLen = ThisDrawing.Utility.GetDistance(chordPoint, "确定引线长度：")
'在模型空间创建半径尺寸标注
Set dimObj = ThisDrawing.ModelSpace. _
AddDimDiametric(chordPoint, FarchordPoint, leaderLen)
'ZoomAll
dimObj.UnitsFormat = acDimLDecimal
dimObj.DecimalSeparator = "."
dimObj.ArrowheadSize = 5.5
dimObj.TextHeight = 6
dimObj.TextGap = 2.5
'dimObj.FractionFormat = acNotStacked
'dimObj.Fit = acTextAndArrows
'dimObj.Fit = acArrowsOnly
'dimObj.ForceLineInside = True
'dimObj.LeaderLength = 10
'dimObj.TextOutsideAlign = True
'dimObj.TextInsideAlign = True
'dimObj.DimLineSuppress = True
'dimObj.HorizontalTextPosition = acFirstExtensionLineNot suported
'dimObj.VerticalTextPosition = acVertCentered
'dimObj.CenterType = acCenterMark
'dimObj.CenterMarkSize = 5
'dimObj.ExtensionLineOffset = 10 该属性在此不被支持
Dim diaString As String
Dim Position As Integer
'MsgBox "Radius = " & entObj.Radius
'求标注值中小数点所在的位数
Position = InStr(1, CStr(entObj.Diameter), ".")
'重新设定标注值保证小数点后2位数
diaStr = "{\Fgdt;n}" & Left(CStr(entObj.Diameter), Posion + 2)
dimObj.TextOverride = diaStr
'ThisDrawing.Regen acActiveViewport
'MsgBox "标注文字的旋转角：" & dimObj.TextRotation
End Sub 深入挖掘MCCD的好东东.
页:
[1]