[例程]使用尺寸--引线标注

mccad

Public Sub CreateLeader()

    ThisDrawing.ActiveTextStyle.fontFile = "c:\windows\fonts\simsun.ttf"
   
    Dim leaderObj As AcadLeader
    Dim points(0 To 8) As Double
    Dim xPnt As Variant, I As Integer
    Dim leaderType As Integer
    Dim annotation As AcadObject
   
    '选择用来确定引线的点数组
    xPnt = ThisDrawing.Utility.GetPoint(, " 选择第 1个点： ")
    points(0) = xPnt(0): points(1) = xPnt(1): points(2) = xPnt(2)
    For I = 1 To 2
        xPnt = ThisDrawing.Utility.GetPoint _
               (xPnt, "选择第" & I + 1 & "点： ")
        points(3 * I) = xPnt(0)
        points(3 * I + 1) = xPnt(1)
        points(3 * I + 2) = xPnt(2)
    Next
   
    '定义引线的形式
    leaderType = acLineWithArrow         '带箭头的直线段
    'leaderType = acSplineWithArrow
    '不使用标注注释
    'Set annotation = Nothing
        
    '在模型空间创建引线标注
    Set leaderObj = ThisDrawing.ModelSpace.AddLeader _
                    (points, annotation, leaderType)
                        
'---------------------------------------------------------
    Dim mtxtObj As AcadMText
    Dim Width As Double
    Dim mtxtStr As String
    Dim inspnt1(0 To 2) As Double
    Dim inspnt2 As Variant
   
    '确定多行文字的书写宽度
    Width = ThisDrawing.Utility.GetReal("选择文字书写宽度: ")
    '从AutoCAD的命令行输入文字
    mtxtStr = ThisDrawing.Utility.GetString(True, "输入标注文字: ")
   
    'On Error Resume Next
    'inspnt2 = ThisDrawing.Utility.GetPoint(xPnt, "选择文字插入点：")
    'If Err <> 0 Then
    '    inspnt1(0) = xPnt(0): inspnt1(1) = xPnt(1) + 3.5: inspnt1(2) = xPnt(2)
    '    Set mtxtObj = ThisDrawing.ModelSpace.AddMText(inspnt1, Width, mtxtStr)
    'Else
    '    Set mtxtObj = ThisDrawing.ModelSpace.AddMText(inspnt2, Width, mtxtStr)
    'End If
    'mtxtObj.Height = 7
   
    '创建多行文字对象
    'Dim insertPnt(0 To 2) As Double
    'insertPnt(0) = xPnt(0): insertPnt(1) = xPnt(1) + 3.5: insertPnt(2) = xPnt(2)
    xPnt(1) = xPnt(1) + 3.5
    Set annotation = ThisDrawing.ModelSpace.AddMText _
                      (xPnt, Width, mtxtStr)
    '设置多行文字的高度
    annotation.Height = 7
   
    'insPnt = annotation.insertionPoint
    'insPnt(1) = insPnt(1) + 3.5
    'annotation.insertionPoint = insPnt
   
   
    'ZoomAll
'-----------------------------------------------------------
    'leaderObj.ArrowheadType = acArrowOpen
    'leaderObj.TextGap = 3
    'leaderObj.TextHeight = 7 不支持该属性
    leaderObj.ArrowheadSize = 10      '设置箭头的尺寸
    'leaderObj.VerticalTextPosition = acVertCentered
   
End Sub

齿轮设计

这个工具不是太理想，要求输入的太多，能不能改一下，点选插入点，放置点，输入文字，结束。文字在引线的上方，下划线自动和文字宽度对齐，这样的功能好做吗？

crazylsp

谢谢供应,修改下来用用。

清风明月名字

谢谢楼主，收藏 使用