[例程]使用尺寸--角度标注

mccad

Public Sub Use3PDimAngle()

    Dim DimPointAngularObj As AcadDim3PointAngular
    Dim AngleVertex As Variant
    Dim FirstPoint As Variant, SecondPoint As Variant
    Dim TextPoint As Variant
   
    ' Define the new Dim3PointAngular object
    'AngleVertex(0) = 0: AngleVertex(1) = 0: AngleVertex(2) = 0
    'FirstPoint(0) = 50: FirstPoint(1) = 50: FirstPoint(2) = 0
    'SecondPoint(0) = 50: SecondPoint(1) = 100: SecondPoint(2) = 0
    'TextPoint(0) = 150: TextPoint(1) = 150: TextPoint(2) = 0

    AngleVertex = ThisDrawing.Utility.GetPoint(, "选择第1个点：")
    FirstPoint = ThisDrawing.Utility.GetPoint(, "选择第2个点：")
    SecondPoint = ThisDrawing.Utility.GetPoint(, "选择第3个点：")
    'TextPoint = ThisDrawing.Utility.GetPoint(SecondPoint, "选择文字位置：")
   
    ' Create the new Dim3PointAngular object in model space
    Set DimPointAngularObj = ThisDrawing.ModelSpace.AddDim3PointAngular(AngleVertex, FirstPoint, SecondPoint, TextPoint)

    'ZoomAll
   
    'MsgBox "A Dim3PointAngular object has been created."

End Sub

Public Sub DimAngular()

    Dim entObj1 As AcadEntity
    Dim pickPnt1 As Variant
    Dim oldOSMODE As Integer
   
    '选择被标注多义线的第1个标注边
    ThisDrawing.Utility.GetEntity entObj1, pickPnt1, "选择被标注对象："
    If StrComp(entObj1.ObjectName, "AcDbPolyline", 1) <> 0 Then
        MsgBox "选择的图元不是多义线，程序将退出！"
        Exit Sub
    End If
   
    Dim vetexCount As Integer               '多义线顶点数
    Dim sVetex As Variant                   '始顶点坐标
    Dim eVetex As Variant                   '终顶点坐标

    '先求出顶点的元素数
    vetexCount = UBound(entObj1.Coordinates)
    '求顶点个数
    vetexCount = (vetexCount + 1) / 2
    '准备判断第1个顶点和最后一个顶点是否重合
    sVetex = entObj1.Coordinate(0)
    eVetex = entObj1.Coordinate(vetexCount - 1)
    '求多义线非自动闭合时的实际顶点个数
    If sVetex(0) = eVetex(0) And sVetex(1) = eVetex(1) Then
        vetexCount = vetexCount - 1
    End If
   
    oldOSMODE = ThisDrawing.GetVariable("OSMODE")
    ThisDrawing.SetVariable "OSMODE", 512

    Dim dimPnt1 As Variant, dimPnt2 As Variant
    dimPnt1 = ThisDrawing.Utility.GetPoint(, "选择第一个标注点：")
    dimPnt2 = ThisDrawing.Utility.GetPoint(, "选择第二个标注点：")
   
'------------------------------------------------------------------
    Dim I As Integer, J As Integer
    Dim lineObj1 As AcadLine
    Dim lineObj2 As AcadLine
    Dim sPnt(0 To 2) As Double
    Dim ePnt(0 To 2) As Double
    Dim X As String, Y As String
   
    On Error Resume Next
    '判断第一条临时直线的交点落在多义线的哪条边上
    For I = 0 To vetexCount - 2
        sVetex = entObj1.Coordinate(I)
        eVetex = entObj1.Coordinate(I + 1)
        Y = (dimPnt1(1) - sVetex(1)) / (eVetex(1) - sVetex(1))
        X = (dimPnt1(0) - sVetex(0)) / (eVetex(0) - sVetex(0))
        'MsgBox "X1 = " & X & Chr(13) & "Y1 = " & Y
        If StrComp(X, Y, 1) = 0 Then
            sPnt(0) = sVetex(0): sPnt(1) = sVetex(1): sPnt(2) = 0
            ePnt(0) = eVetex(0): ePnt(1) = eVetex(1): ePnt(2) = 0
            Set lineObj1 = ThisDrawing.ModelSpace.AddLine(sPnt, ePnt)
            lineObj1.Visible = False
            GoTo lineMark1
        End If
    Next
   
    sVetex = entObj1.Coordinate(0)
    eVetex = entObj1.Coordinate(vetexCount - 1)
    Y = (dimPnt1(1) - sVetex(1)) / (eVetex(1) - sVetex(1))
    X = (dimPnt1(0) - sVetex(0)) / (eVetex(0) - sVetex(0))
    'MsgBox "X1 = " & X & Chr(13) & "Y1 = " & Y
    If StrComp(X, Y, 1) = 0 Then
        sPnt(0) = sVetex(0): sPnt(1) = sVetex(1): sPnt(2) = 0
        ePnt(0) = eVetex(0): ePnt(1) = eVetex(1): ePnt(2) = 0
        Set lineObj1 = ThisDrawing.ModelSpace.AddLine(sPnt, ePnt)
        lineObj1.Visible = False
    End If
   
lineMark1:

    For I = 0 To vetexCount - 2
        sVetex = entObj1.Coordinate(I)
        eVetex = entObj1.Coordinate(I + 1)
        Y = (dimPnt2(1) - sVetex(1)) / (eVetex(1) - sVetex(1))
        X = (dimPnt2(0) - sVetex(0)) / (eVetex(0) - sVetex(0))
        'MsgBox "X2 = " & X & Chr(13) & "Y2 = " & Y
        If StrComp(X, Y, 1) = 0 Then
            sPnt(0) = sVetex(0): sPnt(1) = sVetex(1): sPnt(2) = 0
            ePnt(0) = eVetex(0): ePnt(1) = eVetex(1): ePnt(2) = 0
            Set lineObj2 = ThisDrawing.ModelSpace.AddLine(sPnt, ePnt)
            lineObj2.Visible = False
            GoTo lineMark2
        End If
    Next
   
    sVetex = entObj1.Coordinate(0)
    eVetex = entObj1.Coordinate(vetexCount - 1)
    Y = (dimPnt2(1) - sVetex(1)) / (eVetex(1) - sVetex(1))
    X = (dimPnt2(0) - sVetex(0)) / (eVetex(0) - sVetex(0))
    'MsgBox "X2 = " & X & Chr(13) & "Y2 = " & Y
    If StrComp(X, Y, 1) = 0 Then
        sPnt(0) = sVetex(0): sPnt(1) = sVetex(1): sPnt(2) = 0
        ePnt(0) = eVetex(0): ePnt(1) = eVetex(1): ePnt(2) = 0
        Set lineObj2 = ThisDrawing.ModelSpace.AddLine(sPnt, ePnt)
        lineObj2.Visible = False
    End If
   
'----------------------------------------------------------------
lineMark2:

    Dim dimObj As AcadDimAngular
    Dim insectVert As Variant
    Dim angVert(0 To 2) As Double
    Dim FirstPoint(0 To 2) As Double
    Dim SecondPoint(0 To 2) As Double
    Dim TextPoint As Variant
   
    '求第二和第三条临时直线的交点，此交点
    '就是要标注的2条边的角度标注的标注顶点
    insectVert = lineObj1.IntersectWith(lineObj2, acExtendBoth)
   
    '删除已不用的临时线
    lineObj1.Delete
    lineObj2.Delete
   
    ThisDrawing.SetVariable "OSMODE", oldOSMODE
   
    On Error Resume Next
    '确定角度标注的顶点
    angVert(0) = insectVert(0)
    angVert(1) = insectVert(1)
    angVert(2) = insectVert(2)
    '确定第一条标注边上的标注点
    FirstPoint(0) = dimPnt1(0)
    FirstPoint(1) = dimPnt1(1)
    FirstPoint(2) = dimPnt1(2)
    '确定第二条标注边上的标注点
    SecondPoint(0) = dimPnt2(0)
    SecondPoint(1) = dimPnt2(1)
    SecondPoint(2) = dimPnt2(2)
    '确定标注文字的位置
    TextPoint = ThisDrawing.Utility.GetPoint(SecondPoint, "选择标注文字位置：")
   
    '创建角度尺寸标注对象
    Set dimObj = ThisDrawing.ModelSpace.AddDimAngular(angVert, FirstPoint, SecondPoint, TextPoint)
   
    'ZoomAll
   
End Sub

Public Sub Add5PointDimAngular()

    Dim dPnt1 As Variant, dPnt2 As Variant
    Dim dPnt3 As Variant, dPnt4 As Variant
    Dim oldOSMODE As Integer
   
    '保存原目标捕捉的设定
    oldOSMODE = ThisDrawing.GetVariable("OSMODE")
    '设定自动捕捉图元对象上的最近点
    ThisDrawing.SetVariable "OSMODE", 512
   
    '选择第1条尺寸界线上的第1个标注点
    dPnt1 = ThisDrawing.Utility.GetPoint(, "选择界线1标注点1：")
    '选择第1条尺寸界线上的第2个标注点
    dPnt2 = ThisDrawing.Utility.GetPoint(dPnt1, "选择界线1标注点2：")
    '选择第2条尺寸界线上的第1个标注点
    dPnt3 = ThisDrawing.Utility.GetPoint(, "选择界线2标注点1：")
    '选择第2条尺寸界线上的第2个标注点
    dPnt4 = ThisDrawing.Utility.GetPoint(dPnt3, "选择界线2标注点2：")
   
    Dim lineObj1 As AcadLine, lineObj2 As AcadLine
    Dim insectPnt As Variant
   
    '创建第1条临时尺寸界线
    Set lineObj1 = ThisDrawing.ModelSpace.AddLine(dPnt1, dPnt2)
    lineObj1.Visible = False        '将其设为不可见
    '创建第2条临时尺寸界线
    Set lineObj2 = ThisDrawing.ModelSpace.AddLine(dPnt3, dPnt4)
    lineObj2.Visible = False
    '求出2条临时尺寸界线的交点，即标注顶点angVert
    insectPnt = lineObj1.IntersectWith(lineObj2, acExtendBoth)
   
    '恢复原来的目标捕捉设定
    ThisDrawing.SetVariable "OSMODE", oldOSMODE
   
    '删除2条临时尺寸界线
    lineObj1.Delete
    lineObj2.Delete
   
'--------------------------------------------------------------
    Dim dimObj As AcadDimAngular
    Dim TextPoint As Variant

    '选定标注文字的显示位置
    TextPoint = ThisDrawing.Utility.GetPoint(dPnt4, "选择标注文字位置：")
   
    '用dPnt1点作为FirstPoint点，dPnt3点作为SecondPoint点
    Set dimObj = ThisDrawing.ModelSpace.AddDimAngular(insectPnt, dPnt1, dPnt3, TextPoint)
   
    dimObj.AngleFormat = acRadians
   
End Sub